Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/classes.lisp

Kind	Covered	All	%
expression	2492	5490	45.4
branch	88	278	31.7

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.implementation; -*-

2

3

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

4

5

(:documentation "algebra engine classes"

6

7

"The query engine processes one primary data flow. query requests pass from a client to the

8

engine, are matched against graphs in a specified repository to generate solutions, which are

9

reduced as per the query expression and passed back to the client as a solution stream.

10

11

In addition, the engine accepts system messages for control and maintenance operations, emits error

12

to indicate a request failure and accounting messages to record resource use.

13

The principle response message is encoded as specified in the requests ACCEPT argument, which allows

14

for standard query respeonce forms respective the query operation.

15

16

The control-flow for a query involves numerous reified instances.

17

In addition to the query itself, there are

18

- account : the store account ssociated with the target repository

19

- agent : the authenticated agent

20

- repository : the store repository

21

- profile : reified representation for account or repository metadata/configuration

22

- authorization-list : collection of (access-mode x agent) permissions

23

24

These are maintained as cached persistent instances and synchronized with the store on reference.")

25

26

;;;

27

;;; generic interface operators

28

29

(defgeneric task-dataset-graphs (context)

30

(:method ((context null))

31

*dataset-graphs*))

32

33

;;; define the interface to error terms

34

;;; these appear as the content of a BERT error response

35

36

(defstruct (error-term (:type vector))

37

   "An error-term represents an error report from the sae to the client or from the store to the sae.

38

The error codes are underspecified, so we'll use http codes. The condition is the respective sources

39

condition class name. The detail is the formatter condition report. The backtrace is ignored.

40

The options contain a bgp id when the reponse is from the store to the sae."

41

type

42

code

43

condition

44

detail

45

backtrace

46

options)

47

48

(macrolet ((def-option-accessor (((keyword name) type) default)

49

(let ((keyword (intern keyword :keyword))

50

(error-term-op (cons-symbol *package* :error-term- name)))

51

`(progn

52

(defgeneric ,error-term-op (message-term)

53

                     (:documentation ,(format nil "Get the ~a from a error term's options." name))

54

(:method ((mt vector))

55

(or (rest (assoc ,keyword (error-term-options mt))) ,default)))

56

(defgeneric (setf ,error-term-op) (value message-term)

57

                     (:documentation ,(format nil "Set the ~a in a error term's options." name))

58

(:method ((,name ,type) (mt vector))

59

(let ((entry (assoc ,keyword (error-term-options mt))))

60

(cond (entry

61

(setf (rest entry) ,name))

62

(t

63

                                (push (cons ,keyword ,name) (error-term-options mt))

64

,name)))))))))

65

(def-option-accessor (("bgp_id" bgp-id) string) nil))

66

67

68

(defstruct (account-note (:type list))

69

   "An account-note represents a summary of the resources used by a query task for a single processing step.

70

  Each note comprises the rpository ans task ids and an a-list which contains the step name and counts for

71

time, bytes, and statements"

72

repository-id

73

task-id

74

options

75

timestamp)

76

77

(macrolet ((def-option-accessor (((keyword name) type) default)

78

(let ((keyword (intern keyword :keyword))

79

(term-op (cons-symbol *package* :account-note- name)))

80

`(progn

81

(defgeneric ,term-op (message-term)

82

                     (:documentation ,(format nil "Get the ~a from an account note's options." name))

83

(:method ((mt list))

84

                       (or (rest (assoc ,keyword (account-note-options mt) :test #'string-equal)) ,default)))

85

(defgeneric (setf ,term-op) (value message-term)

86

                     (:documentation ,(format nil "Set the ~a in an account note's options." name))

87

(:method ((,name ,type) (mt list))

88

                       (let ((entry (assoc ,keyword (account-note-options mt) :test #'string-equal)))

89

(cond (entry

90

(setf (rest entry) ,name))

91

(t

92

                                (push (cons ,keyword ,name) (account-note-options mt))

93

,name)))))))))

94

(def-option-accessor (("state" state) symbol) nil)

95

(def-option-accessor (("time" time) number) 0)

96

(def-option-accessor (("bytes" bytes) number) 0)

97

(def-option-accessor (("statements" statements) number) 0))

98

99

100

(defstruct triple subject predicate object id)

101

102

(defstruct (quad (:include triple)) graph)

103

104

(defstruct (tquad (:include quad)) time)

105

106

(defstruct graph name statements)

107

108

(defgeneric triple-graph (statement)

109

(:method ((stmt triple)) '|rdf|:|nil|)

110

(:method ((stmt quad)) (quad-graph stmt)))

111

112

(defmethod make-load-form ((stmt triple) &optional env)

113

(declare (ignore env))

114

(values

115

`(make-triple :subject ',(triple-subject stmt)

116

:predicate ',(triple-predicate stmt)

117

:object ',(triple-object stmt))

118

nil))

119

120

(defmethod make-load-form ((stmt quad) &optional env)

121

(declare (ignore env))

122

(values

123

`(make-quad :subject ',(quad-subject stmt)

124

:predicate ',(quad-predicate stmt)

125

:object ',(quad-object stmt)

126

:graph ',(quad-graph stmt))

127

nil))

128

129

(defgeneric subject (triple)

130

(:method ((triple triple)) (triple-subject triple))

131

(:method ((triple vector))

132

(ecase (length triple)

133

(4 (aref triple 1))

134

(3 (aref triple 0))))

135

(:method ((statement cons))

136

(case (first statement)

137

((spocq.a:|triple| :triple spocq.a:|quad| :quad) (second statement))

138

(t (case (length statement)

139

;; 3 -> s.p.o, 4 -> c.s.p.o

140

(3 (first statement))

141

(4 (second statement)))))))

142

143

(defgeneric (setf subject) (subject triple)

144

(:method (value (triple triple)) (setf (triple-subject triple) value))

145

(:method (value (triple vector))

146

(ecase (length triple)

147

(4 (setf (aref triple 1) value))

148

(3 (setf (aref triple 0) value)))))

149

150

151

(defgeneric predicate (triple)

152

(:method ((triple triple)) (triple-predicate triple))

153

(:method ((triple vector))

154

(ecase (length triple)

155

(4 (aref triple 2))

156

(3 (aref triple 1))))

157

(:method ((statement cons))

158

(case (first statement)

159

((spocq.a:|triple| :triple spocq.a:|quad| :quad) (third statement))

160

(t (case (length statement)

161

;; 3 -> s.p.o, 4 -> c.s.p.o

162

(3 (second statement))

163

(4 (third statement)))))))

164

165

(defgeneric (setf predicate) (predicate triple)

166

(:method (value (triple triple)) (setf (triple-predicate triple) value))

167

(:method (value (triple vector))

168

(ecase (length triple)

169

(4 (setf (aref triple 2) value))

170

(3 (setf (aref triple 1) value)))))

171

172

173

(defgeneric object (triple)

174

(:method ((triple triple)) (triple-object triple))

175

(:method ((triple vector))

176

(ecase (length triple)

177

(4 (aref triple 3))

178

(3 (aref triple 2))))

179

(:method ((statement cons))

180

(case (first statement)

181

((spocq.a:|triple| :triple spocq.a:|quad| :quad) (fourth statement))

182

(t (case (length statement)

183

;; 3 -> s.p.o, 4 -> c.s.p.o

184

(3 (third statement))

185

(4 (fourth statement)))))))

186

187

(defgeneric (setf object) (object triple)

188

(:method (value (triple triple)) (setf (triple-object triple) value))

189

(:method (value (triple vector))

190

(ecase (length triple)

191

(4 (setf (aref triple 3) value))

192

(3 (setf (aref triple 2) value)))))

193

194

195

(defgeneric graph (triple)

196

(:method ((triple triple)) nil)

197

(:method ((quad quad)) (quad-graph quad))

198

(:method ((triple vector))

199

(ecase (length triple)

200

(4 (aref triple 0))

201

(3 nil)))

202

(:method ((statement cons))

203

(case (first statement)

204

((spocq.a:|triple| :triple) nil)

205

((spocq.a:|quad| :quad) (fifth statement))

206

(t (case (length statement)

207

;; 3 -> s.p.o, 4 -> c.s.p.o

208

(3 nil)

209

(4 (first statement)))))))

210

211

(defgeneric (setf graph) (graph quad)

212

(:method (value (quad quad)) (setf (quad-graph quad) value))

213

(:method (value (quad vector))

214

(ecase (length quad)

215

(4 (setf (aref quad 0) value)))))

216

217

218

(defgeneric wild-quad-pattern-p (pattern)

219

(:method ((pattern t))

220

(and (null (subject pattern))

221

(null (predicate pattern))

222

(null (object pattern))

223

(null (graph pattern))))

224

(:method ((pattern vector))

225

(and (eql 0 (aref pattern 0))

226

(= 0 (aref pattern 1))

227

(= 0 (aref pattern 2))

228

(or (< (length pattern) 4) (= 0 (aref pattern 3))))))

229

230

231

#+enable-big-data

232

(cffi:defctype term-id :uint64)

233

#-enable-big-data

234

(cffi:defctype term-id :uint32)

235

236

(cffi:defctype revision-ordinal :uint32)

237

238

(cffi:defcstruct quad

239

"Arrange access to a record of four elements, each of which is a term

240

identifier. These appear as index database keys."

241

(context term-id)

242

(subject term-id)

243

(predicate term-id)

244

(object term-id))

245

246

;;; nb. tquad and tstquad are the same type, but distinct for documtation

247

(cffi:defcstruct tquad

248

"Extend a quad record with an element which contains a unix timestamp.

249

Leave the corresponding object term id present in order to remain compatible

250

with existing code, by which the redundant timestamp can be ignored.

251

These appear as temporal index database keys"

252

(context term-id)

253

(subject term-id)

254

(predicate term-id)

255

(object term-id)

256

(time :uint64)) ;; always, additional, 64-bit

257

258

(cffi:defcstruct tsiquad

259

"Extend a quad record with an element which contains a transaction uuid."

260

(context term-id)

261

(subject term-id)

262

(predicate term-id)

263

(object term-id)

264

(uuid (:struct v1-uuid)))

265

266

(cffi:defcstruct tsoquad

267

"Extend a quad record with an element which contains a transaction ordinal."

268

(context term-id)

269

(subject term-id)

270

(predicate term-id)

271

(object term-id)

272

(ordinal revision-ordinal))

273

274

(cffi:defcstruct tstquad

275

"Extend a quad record with an element which contains a transaction timestamp."

276

(context term-id)

277

(subject term-id)

278

(predicate term-id)

279

(object term-id)

280

(time :uint64))

281

282

(defmacro %quad-context (q) `(cffi:foreign-slot-value ,q '(:struct quad) 'context))

283

(defmacro %quad-subject (q) `(cffi:foreign-slot-value ,q '(:struct quad) 'subject))

284

(defmacro %quad-predicate (q) `(cffi:foreign-slot-value ,q '(:struct quad) 'predicate))

285

(defmacro %quad-object (q) `(cffi:foreign-slot-value ,q '(:struct quad) 'object))

286

(defmacro %tquad-context (q) `(cffi:foreign-slot-value ,q '(:struct tquad) 'context))

287

(defmacro %tquad-subject (q) `(cffi:foreign-slot-value ,q '(:struct tquad) 'subject))

288

(defmacro %tquad-predicate (q) `(cffi:foreign-slot-value ,q '(:struct tquad) 'predicate))

289

(defmacro %tquad-object (q) `(cffi:foreign-slot-value ,q '(:struct tquad) 'object))

290

(defmacro %tquad-time (q) `(cffi:foreign-slot-value ,q '(:struct tquad) 'time))

291

(defmacro %tsiquad-subject (q) `(cffi:foreign-slot-value ,q '(:struct tsiquad) 'subject))

292

(defmacro %tsiquad-predicate (q) `(cffi:foreign-slot-value ,q '(:struct tsiquad) 'predicate))

293

(defmacro %tsiquad-object (q) `(cffi:foreign-slot-value ,q '(:struct tsiquad) 'object))

294

(defmacro %tsiquad-context (q) `(cffi:foreign-slot-value ,q '(:struct tsiquad) 'context))

295

(defmacro %tsiquad-uuid (q) `(cffi:foreign-slot-value ,q '(:struct tsiquad) 'uuid))

296

(defmacro %tsoquad-subject (q) `(cffi:foreign-slot-value ,q '(:struct tsoquad) 'subject))

297

(defmacro %tsoquad-predicate (q) `(cffi:foreign-slot-value ,q '(:struct tsoquad) 'predicate))

298

(defmacro %tsoquad-object (q) `(cffi:foreign-slot-value ,q '(:struct tsoquad) 'object))

299

(defmacro %tsoquad-context (q) `(cffi:foreign-slot-value ,q '(:struct tsoquad) 'context))

300

(defmacro %tsoquad-ordinal (q) `(cffi:foreign-slot-value ,q '(:struct tsoquad) 'ordinal))

301

(defmacro %tstquad-subject (q) `(cffi:foreign-slot-value ,q '(:struct tstquad) 'subject))

302

(defmacro %tstquad-predicate (q) `(cffi:foreign-slot-value ,q '(:struct tstquad) 'predicate))

303

(defmacro %tstquad-object (q) `(cffi:foreign-slot-value ,q '(:struct tstquad) 'object))

304

(defmacro %tstquad-context (q) `(cffi:foreign-slot-value ,q '(:struct tstquad) 'context))

305

(defmacro %tstquad-time (q) `(cffi:foreign-slot-value ,q '(:struct tstquad) 'time))

306

307

(defun %copy-quad (%from %to)

308

(let ((byte-count (load-time-value (cffi:foreign-type-size '(:struct quad)))))

309

(loop for i below byte-count

310

do (setf (cffi:mem-aref %to :uint8 i) (cffi:mem-aref %from :uint8 i) ))))

311

(defun %copy-tquad (%from %to)

312

(let ((byte-count (load-time-value (cffi:foreign-type-size '(:struct tquad)))))

313

(loop for i below byte-count

314

do (setf (cffi:mem-aref %to :uint8 i) (cffi:mem-aref %from :uint8 i) ))))

315

(defun %copy-tsoquad (%from %to)

316

(let ((byte-count (load-time-value (cffi:foreign-type-size '(:struct tsoquad)))))

317

(loop for i below byte-count

318

do (setf (cffi:mem-aref %to :uint8 i) (cffi:mem-aref %from :uint8 i) ))))

319

(defun %copy-tsiquad (%from %to)

320

(let ((byte-count (load-time-value (cffi:foreign-type-size '(:struct tsiquad)))))

321

(loop for i below byte-count

322

do (setf (cffi:mem-aref %to :uint8 i) (cffi:mem-aref %from :uint8 i) ))))

323

(defun %copy-tstquad (%from %to)

324

(let ((byte-count (load-time-value (cffi:foreign-type-size '(:struct tstquad)))))

325

(loop for i below byte-count

326

do (setf (cffi:mem-aref %to :uint8 i) (cffi:mem-aref %from :uint8 i) ))))

327

328

(defun %print-quad (%quad stream)

329

(format stream "~&[~s](~s ~s ~s ~s)~%"

330

%quad

331

(%quad-context %quad) (%quad-subject %quad) (%quad-predicate %quad) (%quad-object %quad))

332

%quad)

333

(defun cl-user::%format-quad (stream %quad option arg)

334

(declare (ignore option arg))

335

(format stream "(~s ~s ~s ~s)"

336

(%quad-context %quad) (%quad-subject %quad) (%quad-predicate %quad) (%quad-object %quad)))

337

338

(defun %print-tquad (%quad stream)

339

(format stream "~&[~s](~s ~s ~s ~s . ~s)~%"

340

%quad

341

           (%tquad-context %quad) (%tquad-subject %quad) (%tquad-predicate %quad) (%tquad-object %quad)

342

(%tquad-time %quad))

343

%quad)

344

(defun cl-user::%format-tquad (stream %quad option arg)

345

(declare (ignore option arg))

346

(format stream "(~s ~s ~s ~s . ~s)"

347

           (%tquad-context %quad) (%tquad-subject %quad) (%tquad-predicate %quad) (%tquad-object %quad)

348

(%tquad-time %quad)))

349

350

(defun %print-tsiquad (%quad stream)

351

(format stream "~&[~s](~s ~s ~s ~s . ~s)~%"

352

%quad

353

           (%tsiquad-context %quad) (%tsiquad-subject %quad) (%tsiquad-predicate %quad) (%tsiquad-object %quad)

354

(uuid:byte-array-to-string (rlmdb:decode-metadata :|revision-uuid| (%tsiquad-uuid %quad))))

355

%quad)

356

(defun %print-tsoquad (%quad stream)

357

(format stream "~&[~s](~s ~s ~s ~s . ~s)~%"

358

%quad

359

           (%tsoquad-context %quad) (%tsoquad-subject %quad) (%tsoquad-predicate %quad) (%tsoquad-object %quad)

360

(%tsoquad-ordinal %quad))

361

%quad)

362

(defun %print-tstquad (%quad stream)

363

(format stream "~&[~s](~s ~s ~s ~s . ~s)~%"

364

%quad

365

           (%tstquad-context %quad) (%tstquad-subject %quad) (%tstquad-predicate %quad) (%tstquad-object %quad)

366

(%tstquad-time %quad))

367

%quad)

368

369

(defclass applicable-query-class (c2mop:funcallable-standard-class)

370

())

371

372

373

(eval-when (#+lispworks :compile-toplevel :load-toplevel :execute)

374

(defmethod c2mop:validate-superclass ((subclass applicable-query-class)

375

(superclass standard-class))

376

t))

377

378

379

;;; agency

380

381

(defclass agent (identified-object)

382

((location :initform nil :initarg :location :reader agent-location)

383

(capabilities :initform (make-registry :test #'equal)

384

:reader agent-capabilities)))

385

386

(defgeneric agent-token (agent)

387

(:method ((agent null)) nil)

388

(:method ((agent agent)) nil))

389

(defgeneric agent-password (agent)

390

(:method ((agent null)) nil)

391

(:method ((agent agent)) nil))

392

(defgeneric agent-name (agent)

393

(:method ((agent null)) nil)

394

(:method ((agent agent)) nil)

395

(:method ((agent string)) agent))

396

(defgeneric agent-account (agent)

397

(:method ((agent null)) nil)

398

(:method ((agent agent)) nil))

399

400

(defclass authenticated-agent (agent)

401

((name

402

:initform nil :initarg :name

403

:reader agent-name)

404

(account

405

:initform nil :initarg :account

406

:reader agent-account)

407

(token

408

:initform nil :initarg :token

409

:reader agent-token)

410

(password

411

:initform nil :initarg :password

412

:reader agent-password))

413

(:documentation

414

"Extend the agent description with eithre a token or a password.

415

The former serves in itself, while the latter is combined with the name"))

416

417

(defclass authority (authenticated-agent)

418

())

419

420

(defclass user (persistent-object authenticated-agent)

421

((name

422

:reader user-name)

423

(account

424

:reader user-account)

425

(email

426

:initform nil :initarg :email

427

:reader user-email

428

:property |http://xmlns.com/foaf/0.1/|:|mbox|)

429

(first-name

430

:initform nil :initarg :first-name

431

:reader user-first-name

432

:property |foaf|:|firstName|)

433

(family-name

434

:initform nil :initarg :family-name

435

:reader user-family-name

436

:property |foaf|:|familyName|))

437

(:metaclass persistent-class))

438

439

(defgeneric user-p (agent)

440

(:method ((user user)) t)

441

(:method ((object t)) nil))

442

443

(defun authenticated-agent-p (object)

444

(typep object 'authenticated-agent))

445

446

(defclass administrator (user)

447

()

448

(:metaclass persistent-class))

449

450

(defgeneric administrator-p (agent)

451

(:method ((agent administrator)) t)

452

(:method ((object t)) nil))

453

454

(defclass located-agent (agent)

455

())

456

457

(defgeneric located-agent-p (agent)

458

(:method ((agent located-agent)) t)

459

(:method ((object t)) nil))

460

461

(defun located-user-p (agent) (located-agent-p agent))

462

463

(defmethod print-object ((object agent) stream)

464

(print-unreadable-object (object stream :identity t :type t)

465

(format stream "'~:[?~;~:*~a~]'~@[@~a~]"

466

(bound-slot-value object 'identifier)

467

(bound-slot-value object 'location))))

468

469

470

(defclass authorized-resource (object-with-persistent-metadata)

471

((authorization-list

472

:initform nil :initarg :authorization-list

473

:reader get-resource-authorization-list :writer setf-resource-authorization-list)

474

(authorized-agents

475

:initform ()

476

:accessor resource-authorized-agents

477

:documentation "a simple a-list, which binds the known authorizations for a given agent.

478

it is constructed on-the-fly as the agents are encountered. no locking is performed,

479

as the consequence of a race would be just repeating the determination."))

480

(:documentation "An abstract class to support access authorization.

481

It includes a site-wide identifier and a list of the authorization contols which

482

have been saved among the respective resource's metadata. These are

483

combined with a requesting agent to determine whether the request is

484

authorized. see access-authorized-p and resource-authorization-list.")

485

(:metaclass persistent-class))

486

487

(defclass authorization-class (persistent-class)

488

())

489

490

(eval-when (#+lispworks :compile-toplevel :load-toplevel :execute)

491

(defmethod c2mop:validate-superclass ((subclass authorization-class)

492

(superclass standard-class))

493

t)

494

)

495

496

(defclass authorization-list (described-object)

497

((resource

498

:initarg :resource

499

:reader authorization-list-resource)

500

(controls

501

:initform nil :initarg :controls

502

:accessor authorization-list-controls)

503

(statements

504

:initform nil

505

:reader authorization-list-statements :writer setf-authorization-list-statements))

506

(:documentation

507

"A reified authorization list provides the store and presentation interface

508

for an access control list.")

509

(:metaclass authorization-class))

510

511

(defclass authorization ()

512

((access-mode

513

:initform nil :initarg :access-mode ; compute-graph-authorization-controls requires initargs

514

:reader authorization-access-mode

515

:property |acl|:|mode|)

516

(access-to

517

:initform nil :initarg :access-to

518

:reader authorization-access-to

519

:property |acl|:|accessTo|)

520

(no-access-to

521

:initform nil :initarg :no-access-to

522

:reader authorization-no-access-to

523

:property |acl|:|noAccessTo|)

524

(agent-class

525

:initform nil :initarg :agent-class

526

:reader authorization-agent-class

527

:property |acl|:|agentClass|))

528

(:documentation "An individual authorization instance specifies access capabilities for

529

some agent or class of agents to some identified resource.")

530

(:metaclass persistent-class))

531

532

(defclass location-authorization (authorization)

533

((location-predicates

534

:initform nil

535

:reader authorization-location-predicates :writer setf-authorization-location-predicates)

536

(locations

537

:initform nil :initarg :locations

538

:reader authorization-locations

539

:property |sioc|:|ip_address|))

540

(:documentation "A location authorization specifies access capabilities for

541

some agent at a given location to some identified resource.")

542

(:metaclass persistent-class))

543

544

(defgeneric location-authorization-p (object)

545

(:method ((object t)) nil)

546

(:method ((object location-authorization)) t))

547

548

(defclass anonymous-authorization (authorization)

549

()

550

(:documentation "An anonymous authorization permits access to some identified resource

551

from a given location.")

552

(:metaclass persistent-class))

553

554

(defmethod authorization-agent-id ((authorization anonymous-authorization))

555

nil)

556

557

558

(defclass anonymous-location-authorization (location-authorization anonymous-authorization)

559

()

560

(:metaclass persistent-class))

561

562

563

(defclass authenticated-authorization (authorization)

564

((agent-id

565

:initform nil :initarg :agent-id

566

:reader authorization-agent-id

567

:property |acl|:|agent|))

568

(:documentation "An authenticated authorization instance specifies access capabilities for

569

a particular identified agent to some identified resource.")

570

(:metaclass persistent-class))

571

572

(defgeneric authenticated-authorization-p (object)

573

(:method ((object t)) nil)

574

(:method ((object authenticated-authorization)) t))

575

576

(defclass authenticated-location-authorization (location-authorization authenticated-authorization)

577

()

578

(:metaclass persistent-class))

579

580

581

582

583

(defclass linked-resource ()

584

((uri :initarg :uri

585

:reader resource-uri :writer setf-resource-uri

586

:documentation "the host-specific identifier for external linked-data access.

587

This may coincide with the internal 'instance identifier', but more likely

588

reflects host-specific properties, such as the host name.")

589

(site-uri

590

:initform nil

591

:reader get-resource-site-uri :writer setf-resource-site-uri

592

:documentation "the site-generic identifier is computed on demand.

593

It replaces the host values of the resource-uri with the site name"))

594

(:documentation "An abstract class to support 'linked data' access.

595

It includes an host-relative identifier to designate the instance with respect

596

to an individual server."))

597

598

(defclass profile-resource ()

599

((title

600

:initarg :title

601

:accessor profile-title

602

:encode-presentation-property |http://purl.org/dc/elements/1.1/|:|title|

603

:documentation "the account name (aka title) is synchronised with the

604

resource name for presentations, but output only.")

605

(email

606

:initarg :email

607

:accessor profile-email

608

:type (or null email-string)

609

:property |http://xmlns.com/foaf/0.1/|:|mbox|)

610

(homepage

611

:initarg :homepage

612

:accessor profile-homepage

613

:type (or null iri)

614

:property |http://xmlns.com/foaf/0.1/|:|homepage|)

615

(weblog

616

:initarg :weblog

617

:accessor profile-weblog

618

:property |http://xmlns.com/foaf/0.1/|:|weblog|)

619

(description

620

:initarg :description

621

:accessor profile-description

622

:property |http://purl.org/dc/elements/1.1/|:|description|))

623

(:metaclass persistent-class)

624

(:documentation "Mix in the properties for description and 'social' interaction"))

625

626

(defclass account (linked-resource profile-resource authorized-resource)

627

((name

628

:initarg :name :initform (error "name is required.")

629

:reader account-name)

630

(user

631

:initarg :user :initform nil

632

:accessor account-user)

633

(owner-id

634

:initarg :owner-id

635

:accessor account-owner-id

636

:encode-presentation-property |acl|:|owner|

637

:documentation "The owner id is generated for the user analogous to the account name

638

for presentation, but output only.

639

It should be identical with that in the global system repository")

640

(capabilities :initform (make-registry :test #'equal)

641

:reader account-capabilities))

642

(:metaclass persistent-class))

643

644

(defclass rdfcache-account (account)

645

()

646

(:metaclass persistent-class))

647

648

649

;; needs to appear before the type reference in query class

650

(defclass repository (linked-resource profile-resource authorized-resource)

651

((id

652

:initform nil

653

:reader repository-id

654

:writer setf-repository-id

655

:documentation "The key for the repository in the store. nb. not the iri.

656

No initarg is provided as the value is verified and set explicitly

657

during instantiation.")

658

(external-name

659

:initarg :external-name :initform nil

660

:reader get-repository-external-name :writer setf-repository-external-name

661

:documentation "the repository's external name is used to construct its uri.")

662

(account

663

:initform nil :initarg :account

664

:reader repository-account

665

:writer setf-repository-account

666

:documentation "the cached account instance to hold metadata")

667

(parent-id

668

:initform nil :initarg :parent-id

669

:accessor repository-parent-id

670

:encode-presentation-property |sioc|:|has_parent|

671

:documentation "Present the parent account id.")

672

(license

673

:initform nil :initarg :license

674

:type (or null iri)

675

:accessor repository-license

676

:property |http://creativecommons.org/ns#|:|license|)

677

(repository-name

678

:initform nil

679

:initarg :name :reader repository-name :reader repository-repository-name

680

:writer setf-repository-repository-name

681

:documentation "the external, account-relative name for the repository")

682

(transaction-class

683

:initform 'transaction :allocation :class

684

:reader repository-transaction-class)

685

(storage-class

686

:initform 'repository-storage :allocation :class

687

:reader repository-storage-class

688

:documentation

689

"The class which implements the concrete storage.

690

This is intended to be declares as an abstract attributes of each specialozation." )

691

(statement-count

692

:initform nil :initarg :statement-count

693

:reader get-repository-statement-count :writer setf-repository-statement-count)

694

(statistics

695

:initform (make-triple-cache :single-thread nil) :initarg :statistics

696

:reader repository-statistics :writer setf-repository-statistics

697

:documentation "A registry with distribution statistics for the repository's data.")

698

(lock

699

:initform (error "lock is required.") :initarg :lock

700

:reader repository-lock)

701

(used-time

702

:initform (get-universal-time)

703

:accessor repository-used-time)

704

(aspect-cache

705

:initform (make-registry :test 'equal)

706

:reader repository-aspect-cache

707

:documentation "caches algebra operator aspects in terms of their sse forms. these are used

708

to avoid recomputing and then compiling the field access operators and predicates anew each

709

time.")

710

(bgp-cache

711

:initform (make-registry :test 'equalp) :initarg :bgp-cache

712

:reader repository-bgp-cache

713

:documentation "caches bgp match functions.")

714

(store->spocq-term-registry

715

:initform nil ;; reusing causs slowdown in sbcl (copy-registry *store->spocq-term-registry*)

716

:reader repository-store->spocq-term-registry

717

:documentation "Maps store identifiers to their spocq:term/native objects in the context of the

718

repository. It starts as a copy of the global registry and accumulates identifiers. Each

719

query for the repository inherits the registry.")

720

(scan-rate

721

:initform *scan-rate* :initarg :scan-rate

722

:accessor repository-scan-rate)

723

(match-rate

724

:initform *match-rate* :initarg :match-rate

725

:accessor repository-match-rate)

726

(wildcard-term

727

:initform rdfcache:*wildcard-term-number* :allocation :class

728

:reader repository-wildcard-term)

729

(all-contexts-term

730

:initarg :all-contexts-term :initform '|urn:dydra|:|all|

731

:reader repository-all-contexts-term

732

     :documentation "The designator to use for all contexts in queries to the repository. The default value is

733

determined based on *all-contexts-term*.")

734

(service-description

735

:initform nil :initarg :service-description

736

:reader get-repository-service-description :writer setf-repository-service-description)

737

(provenance-information

738

:initform nil :initarg :provenance-information

739

:reader get-repository-provenance-information :writer setf-repository-provenance-information)

740

(entailment-cache

741

:initform (make-hash-table :test #'equalp) :reader repository-entailment-cache

742

:documentation "Caches the entailment expansions.")

743

(library-cache

744

:initform (make-registry :test 'equalp)

745

:reader repository-library-cache)

746

(revision-class

747

:documentation "Specify the respective revision class.

748

There is no intform for the abstract class - one must be specified

749

with :class allocation for each concrete class."

750

:allocation :class ;; to be available for access through prototype

751

:reader repository-revision-class))

752

(:metaclass persistent-class)

753

(:documentation "The reified storage entity which combined

754

     - the various identifiers: id, the store id, uri, the linked data designator, and identifier, the

755

site-wide designator

756

- processing metadata

757

- authorization settings

758

- dataset statistics

759

- query forms compiled wrt the datase statistics.

760

     in the course of a query, it resolves to a specific revision, and from that the actual task transaction

761

     which is the context for query processing. The repository itself remains as a cached singleton object

762

and carries state from one query to the next."))

763

764

(defclass shard-repository (repository)

765

()

766

(:documentation "A shard repository stores the terms in a disctionary shard"))

767

768

(defclass repository-storage ()

769

((repository-id

770

:initarg :repository-id :initarg :id :initform nil ;; (error "repository-id is required")

771

:reader repository-id

772

:type string

773

:documentation

774

"Identify the respective store repository.

775

Do not tie back to a repository instance."))

776

(:documentation "The protocol class for delegated repository storage implementations."))

777

778

(defclass file-system-repository (repository)

779

((pathname

780

:initform nil :initarg :pathname

781

:reader get-repository-pathname :writer setf-repository-pathname

782

:documentation "Indicates the file system location for the persistent storage.

783

Supplied at instantiation or computed on demand based on catalog location.")))

784

785

(defclass rdfcache-repository (shard-repository file-system-repository)

786

((store-uri

787

:initform *store-uri* :initarg :uri

788

:reader repository-store-uri)

789

(transaction-class

790

:initform 'rdfcache-transaction :allocation :class)

791

(storage-class

792

:initform 'rdfcache-repository-storage :allocation :class)

793

)

794

(:metaclass persistent-class)

795

(:documentation "Specializes the query operations to perform them with the current rdfcache

796

instance. Each query connects anew with the indicated uri and the id field serves

797

as the revision argument for rdfcache:match operations."))

798

799

(defclass rdfcache-repository-storage (repository-storage)

800

())

801

802

(defclass rdfcache-id-repository (rdfcache-repository)

803

()

804

(:metaclass persistent-class)

805

(:documentation "Specializes rdfcache-repository to employ term identifiers in the

806

algebra operations pervasively."))

807

808

(defclass rdfcache-matrix-repository (rdfcache-id-repository)

809

()

810

(:metaclass persistent-class)

811

(:documentation "Abstract class for repositories which initiate matrix data streams

812

- either consolidated or decimated."))

813

814

(defclass rdfcache-decimated-matrix-repository (rdfcache-matrix-repository)

815

((transaction-class

816

:initform 'rdfcache-decimated-matrix-transaction :allocation :class))

817

(:metaclass persistent-class)

818

(:documentation "Specializes rdfcache-id-repository to use bgp match mechanism which returns

819

solution fields which wrap either materialized matrices or segmented streamed matrices."))

820

821

(defclass rdfcache-consolidated-matrix-repository (rdfcache-matrix-repository)

822

((transaction-class

823

:initform 'rdfcache-consolidated-matrix-transaction :allocation :class))

824

(:metaclass persistent-class)

825

(:documentation "Specializes rdfcache-id-repository to use bgp match mechanism which returns

826

solution fields which wrap either materialized matrices or segmented streamed matrices."))

827

828

(defclass rdfcache-stream-repository (rdfcache-id-repository)

829

()

830

(:metaclass persistent-class)

831

(:documentation "Specializes rdfcache-id-repository to use bgp match mechanism which returns

832

streaming sources."))

833

834

835

(defclass repository-cache (repository)

836

((statements

837

:accessor cache-statements)

838

#+(or) ; obsolete

839

(ephemeral-terms

840

:initform (make-array 32 :fill-pointer 0 :adjustable t)))

841

(:documentation "Specializes query operations to perform them against an in-memory hash-based

842

indexed-repository-cache instance. The id serves as the cache key in the dataset registry."))

843

844

(defclass remote-repository (repository)

845

((transaction-class

846

:initform nil))

847

(:documentation "A repository specialized for remote service queries."))

848

849

(defclass amqp-repository (remote-repository)

850

((channel

851

:initform *store-io* :initarg :channel

852

:reader repository-channel

853

:type stream))

854

(:documentation "Specializes query operations to delegate them to a remote store vis AMQP. With this

855

     methods, the solutions for each graph pattern are computed remotely, returned via amqp, integrated

856

into the query asynchronously, and the query is reduced once all results are available."))

857

858

(defclass service-repository (remote-repository)

859

()

860

(:documentation "A specialized remote repository for sparql service requests."))

861

862

(defclass substitution-service-endpoint (service-repository)

863

()

864

(:documentation "A service repository which requires that any sip values be interpolated in the

865

    the request query, as opposed to passing them as url query arguments or adding a value clause."))

866

867

(defclass sequential-repository-cache (repository-cache)

868

((statements

869

:initform ())))

870

871

(defclass indexed-repository-cache (repository-cache)

872

((statements

873

:initform (make-repository-index))

874

(index-ps

875

:initform (make-repository-index)

876

:reader cache-index-ps)

877

(index-po

878

:initform (make-repository-index)

879

:reader cache-index-po)

880

(index-s

881

:initform (make-repository-index)

882

:reader cache-index-s)

883

(index-p

884

:initform (make-repository-index)

885

:reader cache-index-p)

886

(index-o

887

:initform (make-repository-index)

888

:reader cache-index-o)

889

(index-c

890

:initform (make-repository-index)

891

:reader cache-index-c)))

892

893

894

(defclass numeric-repository-cache (indexed-repository-cache)

895

((terms

896

:initform (make-array 128 :fill-pointer 0 :adjustable t)

897

:reader repository-terms)

898

(spocq->store-term-registry

899

:initform (make-hash-table :test 'equalp)

900

:reader repository-spocq->store-term-registry))

901

(:documentation "A numeric-repository-cache emulates a rdfcache store as a test repository or as

902

a solution cache."))

903

904

905

(defclass term-number-field-cache (indexed-repository-cache)

906

((reference

907

:initform (error "reference is required.") :initarg :reference :type repository

908

:reader repository-reference

909

:documentation "binds the base repository of which this is a version.")

910

(transaction

911

:initform (error "transaction is required.") :initarg :transaction :type transaction

912

:reader repository-transaction))

913

   (:documentation "A numeric-repository-cache emulates a term-number store based on an in-memory statement

914

cache."))

915

916

(defclass repository-revision (repository)

917

((revision-id

918

:initform nil :initarg :revision-id

919

:reader get-repository-revision-id :writer setf-repository-revision-id

920

:documentation "the string uuid")

921

(record

922

:initform nil

923

:reader get-repository-revision-record :writer setf-repository-revision-record

924

:documentation "The store record which describes the transaction which committed the revision")

925

(revision-uri

926

:initform nil

927

:reader get-repository-revision-revision-uri :writer setf-repository-revision-revision-uri

928

:documentation "the revision uuid")

929

#+(or) (uri

930

:initform nil

931

:reader get-repository-revision-uri :writer setf-repository-revision-uri

932

:documentation "the revision resource identifier")

933

(reference

934

:initform (error "reference is required.") :initarg :reference :type repository

935

:reader repository-revision-reference

936

:documentation "binds the base repository of which this is a version.")

937

(reference-revision-id

938

:initform nil :initarg :reference-revision-id

939

:accessor repository-revision-reference-revision-id

940

:documentation "caches the reference repository revision at the point when the revision

941

was instantiated, to be used to decide whether the revision is mutable and whether

942

a subsequent resolve should keep up with the reference.")

943

(start-date-time

944

:initform nil :initarg :start-time

945

:reader repository-revision-get-start-date-time)

946

(end-date-time

947

:initform nil :initarg :end-time

948

:reader repository-revision-get-end-date-time)

949

(revision-ids

950

:initform nil :initarg :revision-ids

951

:reader get-repository-revision-ids :writer setf-repository-revision-ids

952

:documentation "Caches the list of ids of this revision and its predecessors.")

953

(signature

954

:initform nil

955

:reader get-revision-signature :writer setf-revision-signature

956

:documentation "For storage architectures which support digest signature, this

957

caches a value which is computed on-demand.")

958

(designator

959

:initform nil :initarg :designator

960

:accessor repository-revision-designator

961

:documentation "records the symbolic designator which was resolved to this revision")

962

(mode

963

:initform '(:instant) :initarg :mode

964

:accessor repository-revision-mode

965

:documentation "a list of mode keywords which caprutes the revisions operational variants.

966

Serves as the indicators for is-instant-revision, is-interval-revision,

967

is prospective-revision, is-retrospective-revision, etc")))

968

969

970

;;; (describe-class 'repository-revision)

971

972

(defclass rdfcache-repository-revision (repository-revision rdfcache-repository)

973

())

974

975

(defclass rdfcache-stream-repository-revision (repository-revision rdfcache-stream-repository)

976

())

977

978

(defclass rdfcache-matrix-repository-revision (repository-revision)

979

())

980

 (defclass rdfcache-decimated-matrix-repository-revision (rdfcache-matrix-repository-revision  rdfcache-decimated-matrix-repository)

981

())

982

(defclass rdfcache-consolidated-matrix-repository-revision (rdfcache-matrix-repository-revision

983

                                                             rdfcache-consolidated-matrix-repository)

984

())

985

986

987

;;;

988

989

(defclass view (linked-resource identified-object)

990

((repository

991

:initarg :repository :initform (error "repository is required")

992

:reader view-repository)

993

(name

994

:initarg :name :initform (error "name is required")

995

:reader view-name)

996

(uuid

997

:initarg :uuid :initform nil

998

:reader view-uuid :writer setf-view-uuid)

999

(query

1000

:initarg :query :initform nil

1001

:reader get-view-query

1002

:writer (setf view-query))

1003

(sse-expression

1004

:initarg :sse-expression :initform nil

1005

:reader get-view-sse-expression

1006

:writer (setf view-sse-expression)

1007

:documentation

1008

"binds the parsed (lazily parsed) query text.")

1009

(options

1010

:initarg :options :initform nil

1011

:reader get-view-options

1012

:writer (setf view-options))

1013

(service-references

1014

:initarg :references :initform nil

1015

:reader get-view-service-references

1016

:writer (setf view-service-references)

1017

:documentation

1018

"binds a list of service locations, as extracted from the view text")

1019

(view-references

1020

:initarg :references :initform nil

1021

:reader get-view-view-references

1022

:writer (setf view-view-references)

1023

:documentation

1024

"binds a list of sub-views, as extracted from the view text")

1025

(dimensions

1026

:initarg :dimensions :initform nil

1027

:reader get-view-dimensions

1028

:writer (setf view-dimensions))

1029

(parameters

1030

:initarg :parameters :initform nil

1031

:reader view-parameters)

1032

(summary

1033

:initarg :summary :initform nil

1034

:accessor view-summary)))

1035

1036

1037

;;;

1038

1039

(defclass transaction ()

1040

((uri

1041

:initform nil

1042

:reader get-transaction-uri :writer setf-transaction-uri

1043

:documentation "Binds an uri value to use in metadata references")

1044

(id

1045

:initform (error "id is required for a transaction") :initarg :id

1046

:reader transaction-id

1047

:documentation "a generated id bound to the transaction during initialization

1048

This is recorded as the new revision id when a write transaction commits.")

1049

(task-id

1050

:initarg :task-id :initform (task-id *task*)

1051

:reader transaction-task-id

1052

:documentation "Binds the owning task's id as a means to determine owneship when finalizing.")

1053

(revision

1054

:initform nil

1055

:initarg :revision

1056

:reader transaction-revision

1057

:documentation "Binds the respective repository revision to which the

1058

transaction applies. For complex revisions, this will be the initial with

1059

the complete, composite designator, from which individual transaction

1060

captures the details.

1061

This reference back to the revision keeps it active, so longs as the transaction is used.")

1062

(read-only

1063

:initarg :read-only-p

1064

:initform t

1065

:reader transaction-read-only-p)

1066

(revision-id

1067

:initform (error "revision-id is required")

1068

:initarg :revision-id

1069

:reader transaction-revision-id

1070

:documentation "The revision id upon which the transaction is based.")

1071

(lock

1072

:initform (bt:make-lock "transaction lock") :initarg :lock

1073

:reader transaction-lock)

1074

(operation

1075

:initform nil :initarg :operation

1076

:reader transaction-operation)

1077

(api-key

1078

:initform nil :initarg :api-key

1079

:reader transaction-api-key)

1080

(start-time

1081

:initform (get-universal-time)

1082

:reader transaction-start-time)

1083

(end-time

1084

:initform nil

1085

:accessor transaction-end-time)

1086

(created-graph-ids

1087

:initform (make-term-id-cache :single-thread nil)

1088

:accessor transaction-created-graph-ids

1089

:documentation "The set of graphs which are created by an update query

1090

through an explicit add, create, copy or move operation.")

1091

(deleted-graph-ids

1092

:initform (make-term-id-cache :single-thread nil)

1093

:accessor transaction-deleted-graph-ids

1094

:documentation "The set of graphs which are deleted by an update query

1095

through a move or drop operation.")

1096

(modified-graph-ids

1097

:initform (make-term-id-cache :single-thread nil)

1098

:accessor transaction-modified-graph-ids

1099

:documentation "The set of graphs which are modified by an update query

1100

through an add, move, or copy or otherwise modified by insert/delete

1101

operations on individual statements.")

1102

(read-graph-ids

1103

:initform (make-term-id-cache :single-thread nil)

1104

:accessor transaction-read-graph-ids

1105

:documentation "The set of graphs which contribute to the changes in a

1106

transaction by virtue of their appearance in a graph-qualified bgp.")

1107

(wildcard-term

1108

:initform rdfcache:*wildcard-term-number* :allocation :class

1109

:reader repository-wildcard-term)

1110

(delete-count

1111

:initform 0

1112

:accessor transaction-delete-count)

1113

(insert-count

1114

:initform 0

1115

:accessor transaction-insert-count)

1116

(all-graph-uri

1117

:initform |urn:dydra|:|all| :allocation :class

1118

:reader transaction-all-graph-uri)

1119

(default-graph-uri

1120

:initform |urn:dydra|:|default| :allocation :class

1121

:reader transaction-default-graph-uri)

1122

(named-graph-uri

1123

:initform |urn:dydra|:|named| :allocation :class

1124

:reader transaction-named-graph-uri))

1125

(:documentation

1126

"A transaction combines at least the identifier and intended revision uuid

1127

for the target repository with an new uuid. Iff a write transaction

1128

commits, this uuid becomes the new revision uuid. A supplied api-key is

1129

incorporated into the store-level transaction to permit store- and

1130

graph-level authorization. In addition graph identies are cached to

1131

be included in provenance information for update queries."))

1132

1133

(defclass shard-transaction (transaction)

1134

()

1135

(:documentation

1136

"A shard transaction concerns a repository for which the terms are recorded in the

1137

sharded term dictionary"))

1138

1139

(defclass rdfcache-transaction (shard-transaction)

1140

((record

1141

:initform (error "record is required.")

1142

:type cffi-sys:foreign-pointer

1143

:reader transaction-record :writer setf-transaction-record

1144

:documentation "Binds the rdfcache native transaction record wrapped by this

1145

instance. It is created during initialization and released explicitly

1146

by destroy-transaction, which is invoked when a query is de-registered.")))

1147

1148

1149

(defclass resource-record-transaction (transaction)

1150

((created-resource-ids

1151

:initform (make-term-id-cache :single-thread nil)

1152

:accessor transaction-created-resource-ids

1153

:documentation "The set of resources which are created by an update query

1154

through an explicit rdf:type assertion.")

1155

(modified-resource-ids

1156

:initform (make-term-id-cache :single-thread nil)

1157

:accessor transaction-modified-resource-ids

1158

:documentation "The set of resources which are modified by an update query

1159

through an add, move, or copy or otherwise modified by insert/delete

1160

operations on individual statements without rdf:type")))

1161

1162

(defclass rdfcache-resource-record-transaction (rdfcache-transaction

1163

                                                 resource-record-transaction)

1164

())

1165

1166

(defclass matrix-transaction (transaction)

1167

())

1168

1169

(defclass rdfcache-matrix-transaction (rdfcache-transaction matrix-transaction)

1170

())

1171

1172

(defclass rdfcache-decimated-matrix-transaction (rdfcache-matrix-transaction)

1173

())

1174

1175

(defclass rdfcache-consolidated-matrix-transaction (rdfcache-matrix-transaction)

1176

())

1177

1178

1179

#+sbcl

1180

(defmethod transaction-record ((record SB-SYS:SYSTEM-AREA-POINTER))

1181

record)

1182

1183

(defmethod transaction-record ((transaction null))

1184

nil)

1185

1186

#-sbcl

1187

(defmethod transaction-record ((record t))

1188

(assert-argument-type transaction-record record cffi-sys:foreign-pointer)

1189

record)

1190

1191

(defgeneric transaction-timestamp (transaction)

1192

(:method ((transaction null))

1193

nil)

1194

(:method ((transaction spocq.i::rdfcache-transaction))

1195

(let ((%record (spocq.i::transaction-record transaction)))

1196

(if %record

1197

(rdfcache::%%transaction-begin %record)

1198

0))))

1199

1200

1201

(defclass repository-index ()

1202

())

1203

1204

(defgeneric compute-index-statements (index statements filters)

1205

(:documentation "given the pertinent quad statements and filters,

1206

construct a bgp:index statement respective the index."))

1207

1208

(defgeneric translate-index-expression (index expression patterns)

1209

(:documentation "translate the given expression into a test form in the syntax and terms

1210

of the respective index.")

1211

1212

(:method ((index null) (expression t) (patterns t))

1213

(format nil "null index: ~s ~s" expression patterns)))

1214

1215

1216

;;;

1217

;;; reified run-time settings

1218

1219

(defclass request-processor ()

1220

((configuration-location

1221

:initarg :configuration-location :initform nil

1222

:reader processor-configuration-location)

1223

(request-content-location

1224

:initarg :request-content-location

1225

:initform (error "request-content-location is required.")

1226

:reader processor-request-content-location)

1227

(request-content-type

1228

:initarg :request-content-type

1229

:initform (error "request-content-type is required.")

1230

:reader processor-request-content-type)

1231

(response-content-location

1232

:initarg :response-content-location

1233

:initform (error "response-content-location is required.")

1234

:reader processor-response-content-location)

1235

(response-content-type

1236

:initarg :response-content-type

1237

:initform (error "response-content-type is required.")

1238

:reader processor-response-content-type)

1239

(accounting-location

1240

:initarg :account-location

1241

:initform *accounting-destination*

1242

:reader processor-accounting-location)

1243

(error-location

1244

:initarg :error-location

1245

:initform *error-destination*

1246

:reader processor-error-location)))

1247

1248

1249

1250

1251

(defclass http-request-processor (request-processor)

1252

((request-uri

1253

:initarg :request-uri

1254

:reader processor-request-uri)))

1255

1256

(defclass amqp-request-processor (request-processor)

1257

())

1258

1259

(defclass shell-request-processor (request-processor)

1260

((configuration-location

1261

:initform *standard-input*)

1262

(request-content-location

1263

:initform *standard-input*)

1264

(request-content-type

1265

:initform *request-content-type*)

1266

(response-content-location

1267

:initform *standard-output*)

1268

(response-content-type

1269

:initform *response-content-type*))

1270

(:documentation

1271

"Control the run-times which accept a request stream from standard input, process it

1272

and emit the results to standard output/error."))

1273

1274

(defun request-processor ()

1275

(or *request-processor*

1276

(setq *request-processor* (make-instance *class.request-processor*))))

1277

1278

;;; protocol classes for entailment implementations

1279

1280

(defclass entailment-method ()

1281

((task

1282

:initform *task* :initarg :task

1283

:reader entailment-regime-task

1284

:documentation "Binds the task which is the context for applying the regime to

1285

the query patterns.")

1286

(dataset

1287

:initform (error "dataset is required.") :initarg :dataset

1288

:reader entailment-regime-dataset

1289

:documentation "Locates the library repository which contains the definitions

1290

for the regime rules.")

1291

(if-does-not-exist

1292

:initform nil :initarg :if-does-not-exist

1293

:reader entailment-method-if-does-not-exist))

1294

(:documentation

1295

"entailment-regime serves as the abstract root for all regime protocol classes.

1296

It binds the context task and the definition library location.

1297

The specializations are intended to be arrange in precedence to achieve the

1298

intended rewrite order by specifying a concrete combination class as the methd

1299

for a processing definition. The respective methods then implement own and

1300

next processing as they see fit."))

1301

1302

#|

1303

(defclass |urn:dydra|::|SemanticAuthorization| (entailment-method)

1304

())

1305

1306

(defclass |urn:dydra|:|RIFCore| (entailment-method)

1307

())

1308

1309

(defclass <http://www.w3.org/ns/entailment/D> (entailment-method)

1310

())

1311

1312

(defclass <http://spinrdf.org/sp> (entailment-method)

1313

())

1314

|#

1315

1316

;;;

1317

1318

(defclass task (object-with-metadata)

1319

((id

1320

:initarg :id :initarg :task-id :type string

1321

:reader task-id)

1322

(name

1323

:initarg :name :initform *task-name*

1324

:accessor task-name

1325

:documentation "retains a categorical name for the task. In particular view names for queries.")

1326

(agent

1327

:initform nil :initarg :agent

1328

:accessor task-agent

1329

:documentation "The agent which is authorized for the task. This encapsulates

1330

any identity information - including location, name, session and/or tokens")

1331

(user-id

1332

:initform nil :initarg :user-id :initarg :|user_id| :type (or string null)

1333

:reader task-user-id :reader task-user-tag)

1334

(operation

1335

:initarg :operation :initform :select :type symbol

1336

:reader task-operation :writer setf-task-operation)

1337

(request-exchange

1338

:initform nil :initarg :request-exchange :initarg :|exchange|

1339

:type string

1340

:reader task-request-exchange

1341

     :documentation "The exchange from which the tasked request was recieved - which is also the exchange

1342

to which to publish its response.")

1343

(request-routing-key

1344

:initform nil :initarg :request-routing-key :initarg :|routing_key|

1345

:type string

1346

:reader task-request-routing-key

1347

:documentation "The routing key to attached to a response message is extracted from the

1348

request message options.")

1349

(state

1350

:initform :initialize

1351

:accessor task-state)

1352

(start-run-time

1353

:initform (get-internal-run-time)

1354

:accessor task-start-run-time)

1355

(start-real-time

1356

:initform (get-internal-real-time)

1357

:accessor task-start-real-time)

1358

(request-location

1359

:initarg :request-location :initform |urn:dydra|:|requestContent| ;; |http|:|body|

1360

:accessor task-request-location

1361

:documentation "Indicate where to find the request query document.

1362

Default is the http request body.")

1363

(request-content-type

1364

:initarg :request-content-type

1365

:accessor task-request-content-type

1366

:type mime:*/*

1367

:documentation "specify the content type for request messages.")

1368

(request-signature

1369

:initform nil :initarg :signature :initarg :request-signature

1370

:reader get-task-request-signature :writer (setf task-request-signature)

1371

     :documentation "Caches the SHA1 of the trimmed sparql expression to combine with the repository id

1372

and the parameter names as the key for the prototype cache.")

1373

(request-content

1374

:initform "" :initarg :request-content

1375

:reader task-request-content

1376

:documentation "The request expression as a character string")

1377

(sse-expression

1378

:type cons :initarg :sse-expression

1379

:accessor task-sse-expression)

1380

(response-location

1381

:initarg :response-location :initform |http|:|body|

1382

:accessor task-response-location

1383

:documentation "Indicate where to write the response document content.

1384

Default is the http response body.")

1385

(response-content-type

1386

:initarg :response-content-type

1387

:accessor task-response-content-type

1388

:type mime:*/*

1389

:documentation "specify the content type for response messages.")

1390

(dynamic-bindings

1391

:initform (list nil) :initarg :dynamic-bindings

1392

:accessor task-dynamic-bindings

1393

:documentation "A matched pair of lists of variables and the values to which they are bound

1394

when the query is run.")

1395

(operator-count

1396

:initform 0 :initarg :operator-count

1397

:accessor task-operator-count

1398

:documentation "Indicates the number of algebra operators in the query.

1399

It indirectly specifies the thread count required to process the task full parallel

1400

and is compared by query-run-in-thread with *query-operator-thread-threshold* to determine

1401

       whether to apportion operators to individual threads or process them all in a single thread.")

1402

(parent-task

1403

:initform *task-parent* :initarg :parent-task

1404

:reader task-parent-task

1405

:documentation "Record the next in task/sub-task parentage chain.

1406

      If null, then there is no parent. This is true for autonomous querues and outer script tasks.

1407

      The default, *task-parent* is bound by the scripting run-time when evaluating sub-task operations.")

1408

(indices

1409

:initform (make-task-indices) :initarg :indices

1410

:accessor task-indices

1411

:type task-indices

1412

:documentation "with-task-envirornment establishes and caches this value as a dynamic binding for

1413

*task-indices* for use when parsing and constructing in the task context.")

1414

(thread

1415

:initform (bt:current-thread) :initarg :thread

1416

:accessor task-thread

1417

:documentation "Binds the principle task thread for signaling termination.

1418

The initial value is the thread current when created.

1419

This is modified when processing commences to that thread to which errors whould be relayed.")

1420

(threads

1421

:initform (make-registry :test 'equal)

1422

:accessor task-threads

1423

:type hash-table

1424

:documentation "A registry to collect the tasks's threads. Keyed by thread name.")

1425

(transactions

1426

;; :initform ()

1427

:accessor task-transactions

1428

:documentation "A message queue to collect transactions active during the course of the task.")

1429

(transaction-disposition

1430

:initform :commit :initarg :transaction-disposition

1431

:type (member :commit :continue)

1432

:reader task-transaction-disposition

1433

:documentation "Specifies the disposition for completed write transactions.

1434

      By default, :commit, which causes an update clause in a request to commit immediately upon its

1435

conclusion. The alternative, :continue, is intended for cases where the transaction is supplied

1436

      to the task and its extent exceeds the task's. This applies, for example, to query steps in scripts.")

1437

(operations

1438

;; :initform ()

1439

:accessor task-operations

1440

     :documentation "A queue for the task's pending operations. The first pass of query evaluation stages the

1441

      individual operation expressions to this queue, from which the available algebra threads retrieve and

1442

execute the operations.")

1443

(statistics

1444

:accessor task-statistics

1445

:documentation "contains the collected statistics for a task.")

1446

(accounting-destination

1447

:initform *accounting-destination* :initarg :accounting-destination

1448

:accessor task-accounting-destination

1449

     :documentation "specifies the destination for accounting records to be written when the task is finalized.")

1450

(errors

1451

:accessor task-errors

1452

:documentation "contains error conditions collected during task processing.")

1453

(error-destination

1454

:initform *error-destination* :initarg :error-destination

1455

:accessor task-error-destination

1456

     :documentation "specifies the destination for error notes to be written when the task is finalized.")

1457

(thread-task-semaphore

1458

:reader task-thread-task-semaphore

1459

     :documentation "Guages access to the the thread and operation queues. Each thread waits on this for

1460

      the notification that an operation is available while each published operation signals its availability

1461

here.")

1462

(lock

1463

:reader task-lock)

1464

(properties

1465

:initform () :initarg :properties

1466

:accessor task-properties

1467

     :documentation "A p-list of task specific properties to make request specific settings available to

1468

all processing threads, in particular for the encoding functions."))

1469

(:default-initargs

1470

:id (make-null-task-id))

1471

(:documentation

1472

"A task is the most abstract encapsulation of the information needed to process a request.

1473

     It comprises naming, agency, in/out content type and location and processing metadata, but nothing about

1474

     the concrete operation. In some cases, a specialized form, a query, includes more information for

1475

processing an individual query. In other cases, the abstract form is used to wrap several

1476

sub-tasks/queries and provide context information.

1477

     This applies, in particular, to transactions, which can span subtasks, for example in order to apply a

1478

     constraint sub-query to the state of an active transaction and commit that state only when constraint succeeds.

1479

     This result is that a task can close only those transactions which it owns and must continue all others,

1480

to allow some parent task to effect their disposition."))

1481

1482

1483

1484

(defclass data-task (task)

1485

((account

1486

:initarg :account :initform nil

1487

:reader task-account

1488

     :documentation "When a task is authenticated for access by a specific account, this holds that account

1489

in distinction to that known through the repository owner.")

1490

(repository

1491

:initarg :repository :initform nil :type repository

1492

:reader task-repository

1493

     :documentation "An abstract repository instance is designated by an '<acount number>/<repository number>'

1494

      sequence, specializes the implementation for any update operations, and designates the context of

1495

      update operations to the store. It also caches query implementations and sensitivity information.

1496

The repository must be specified before the tak can proceed.

1497

If none has been specified, an error is signaled.")

1498

(revision

1499

:initarg :revision :initform nil :type repository-revision

1500

:accessor task-revision

1501

:documentation "A particular repository revision instance is designated by the revision's uuid,

1502

      specializes the implementation of query operations, and designates the context of query operations

1503

to the store.

1504

The revision must be specified before the tak can proceed.

1505

If none has been specified, the current repositroy revision is used.")

1506

(revision-id

1507

:initarg :revision-id :type string

1508

:accessor task-revision-id

1509

:documentation "This is either a uuid string which identifies a specific revision,

1510

or it is an abstract designator, such as 'HEAD', 'HEAD~2', an iso date string

1511

or someother designator which must be transformed into an identifier for each occasion.

1512

The default value is 'HEAD', which causes clones to track the current revision.")

1513

(transaction

1514

:initform nil

1515

:reader get-task-transaction :writer setf-task-transaction

1516

:documentation "When the task concerns a modification with transactional semantics, this

1517

binds the active transaction instance. It is created lazily upon first use and either comitted

1518

when the task completes successfully or aborted if the task fails or is abandoned.")

1519

(result-generator

1520

:accessor task-result-generator

1521

:documentation "A function of one argument, a result continuation, which starts task processing

1522

      when called and supplies successive results to the given continuation, ending the stream with a nil.")

1523

(initialization-function

1524

:initform nil

1525

:accessor task-initialization-function

1526

:documentation "A function of one argument, the task, which initializes it and returns a

1527

result generator.")

1528

(dataset-graphs

1529

:initarg :dataset-graphs :initform nil

1530

:accessor task-dataset-graphs

1531

     :documentation "A property list which combines the default and named graphs to which the query applies.")

1532

(start-time

1533

:initform (get-universal-time) :initarg :start-time

1534

:accessor task-start-time

1535

:documentation "The universal time value when the task was created")

1536

(end-time

1537

:initform nil :initarg :end-time

1538

:accessor task-end-time

1539

     :documentation "The universal time value up until when a repeating task will be re-run. Otherwise null.")

1540

(time-interval

1541

:initform nil :initarg :time-interval

1542

:accessor task-time-interval)

1543

(priority

1544

:initarg :priority :initform *priority*

1545

:reader task-priority

1546

:type integer)

1547

(lexical->spocq-term-registry

1548

:reader task-lexical->spocq-term-registry

1549

:writer setf-task-lexical->spocq-term-registry

1550

:documentation "Maps lexical expressions to spocq:term/native objects in the context of the

1551

      query / repository. It starts as a copy of the global registry and accumulates lexical forms.")

1552

(spocq->store-term-registry

1553

:reader task-spocq->store-term-registry

1554

:writer setf-task-spocq->store-term-registry

1555

:documentation "Maps native objects to their store identifiers in the context of the

1556

query / repository. Terms cache the identifier internally.

1557

It starts as a copy of the global registry and accumulates terms.")

1558

(store->spocq-term-registry

1559

:reader task-store->spocq-term-registry

1560

:writer setf-task-store->spocq-term-registry

1561

:documentation "Maps store identifiers to their spocq:term/native objects in the context of the

1562

query / repository. It starts as a copy of the global registry and accumulates identifiers.")

1563

#+(or) ; obsolete

1564

(ephemeral-terms

1565

:reader task-ephemeral-terms

1566

:writer setf-task-ephemeral-terms

1567

:documentation "Records the identifier -> storage representation for terms which are not (yet)

1568

persistent. Maintained on a per/query bases, as after an ephemeral references has appeared in

1569

a query it most likely persists or does not reappear.")

1570

(commit-constraint

1571

:initform nil :initarg :commit-constraint

1572

:accessor task-commit-constraint

1573

:documentation "binds a view which is to be applied to the repository prior to permitting

1574

      an update operation to commit. limited to queries as graph store operations are done in another process."))

1575

(:documentation "A data-task extends the base task class with dataset and processing parameters."))

1576

1577

1578

(defclass query (data-task)

1579

((id :reader query-id)

1580

(user-id :reader query-user-id)

1581

(result-generator :reader query-result-generator)

1582

(threads :reader query-threads)

1583

(transaction :reader query-transaction)

1584

(request-content

1585

:initarg :sparql-expression :initarg :query-expression

1586

:reader query-sparql-expression

1587

     :documentation "Overlay request content field specific to queries with the sparql expression as a character string")

1588

(request-signature

1589

:initarg :query-signature)

1590

(store-bgp-routing-key

1591

:initform nil :initarg :store-bgp-routing-key

1592

:reader get-task-store-bgp-routing-key :writer setf-task-store-bgp-routing-key

1593

:documentation "binds the routing key to direct bgp requests to a store queue.")

1594

(store-routing-key

1595

:initform (engine-store-routing-key) :initarg :store-routing-key

1596

:type string

1597

:reader task-store-routing-key

1598

:documentation "The routing key is included in the message options if match requests are sent

1599

to the store for it to use to route the responses back to the engine.")

1600

(trace-routing-key

1601

:initform nil :initarg :trace-routing-key :initarg :|trace_routing_key|

1602

:type (or null string)

1603

:reader task-trace-routing-key

1604

:documentation "Iff non-null, this enables trace messages with the query plan and bgp progress.")

1605

(namespace-bindings

1606

:initform () :initarg :namespace-bindings

1607

:reader query-namespace-bindings)

1608

(state

1609

:type (member :initialize :abstract :delegate :bind :reduce :complete :terminate))

1610

(sse-expression

1611

;; as an exception, can be set for static values substitution

1612

:accessor query-sse-expression)

1613

(patterns

1614

:initform () :type list

1615

:accessor query-patterns

1616

     :documentation "Collects the asynchronously computed arguments for the query. The initial value is an

1617

      empty p-list, to which each successively returned bgp result adds an argument identified by the

1618

      bgp id. Once all are present the query's predicate returns true to permit the query's execution.

1619

      If the query is diachronic, the list is cleared, the bgp requests are renewed, and the processes

1620

repeats.")

1621

(variables

1622

:initform () :initarg :variables

1623

:accessor query-variables

1624

:documentation "Records information about variables present in the query")

1625

(dynamic-bindings

1626

:accessor query-dynamic-bindings)

1627

(pattern-rewrite-rule-sets

1628

:initform () :initarg :bgp-rewrite-rule-sets

1629

:accessor query-pattern-rewrite-rule-sets

1630

:documentation "A list of rewrite rule sets.")

1631

(pattern-rewrite-operator

1632

:initform nil

1633

:reader get-query-pattern-rewrite-operator :writer (setf query-pattern-rewrite-operator)

1634

:documentation "A list of functions which each accepts a bgp body and produces a new body

1635

augmented to reflect the respective rules.")

1636

(provenance-record

1637

:initform nil :initarg :provenance-record

1638

:accessor query-provenance-record)

1639

(entailment-method

1640

:initform nil :initarg :entailment-method

1641

:accessor query-entailment-method

1642

:type (or null entailment-method)

1643

:documentation "Reifies the entailment method to be applied when compiling BGPs.

1644

The default is NIL, which reduces the compilation to just the compilation performed

1645

by macroexpand-bgp which then means standard D-entailment, as implemented by the store.

1646

When bound to an entailment method instance, that mixes in other rewrite methods based

1647

in definitions in the methods respective library.")

1648

(library

1649

:initarg :library ; no initform

1650

:writer (setf query-library) :reader get-query-library)

1651

(license

1652

:initform nil :initarg :license

1653

:accessor query-license))

1654

(:metaclass applicable-query-class)

1655

(:default-initargs)

1656

(:documentation

1657

"The applicable-query class models compiled queries, their interdependencies, and their

1658

dependence on bgp results from an external store.

1659

It comprises the original query expression, the entailed BGP queries, and

1660

a function which integrates incident BGP responses to generate results."))

1661

1662

(defclass service-query (query)

1663

()

1664

(:metaclass applicable-query-class)

1665

(:documentation "The service-query specialization introduces controls necessary to

1666

clean up upon gc"))

1667

1668

(defclass script (query)

1669

((sse-expression

1670

:initform ssl::*toplevel-code*

1671

:reader script-code)

1672

(stack

1673

:initform ssl::*toplevel-stack*

1674

:reader script-stack))

1675

(:metaclass applicable-query-class))

1676

1677

(defclass store-data-task (data-task)

1678

((bdp-id

1679

:initform (error "bgp-id is required.") :initarg :bgp-id

1680

:reader task-bgp-id)))

1681

1682

(defclass bgp-match (store-data-task)

1683

((expression

1684

:type cons

1685

:accessor bgp-match-expression)

1686

(lambda

1687

:type cons

1688

:accessor bgp-match-lambda)

1689

(function

1690

:type function

1691

:accessor bgp-match-function)

1692

(patterns

1693

:initform () :type list

1694

:accessor query-patterns

1695

     :documentation "Collects the computed bgp pattern arguments for the query. For a bgp match there should be

1696

just one - the single bgp pattern."))

1697

(:default-initargs :response-content-type *store-content-type*)

1698

(:documentation "A bgp-match task matches a bgp triple pattern agains a repository."))

1699

1700

(defclass store-reply (store-data-task)

1701

((solution-field

1702

:initarg :solution-field :initform nil

1703

:accessor task-solution-field)))

1704

1705

(defclass error-task (task)

1706

((condition :initarg :condition :reader task-condition)

1707

(detail :initarg :detail :reader task-detail))

1708

(:documentation

1709

"An error-task is created when some stage in query processing - especially parsing, signals

1710

an error without recourse to a proper task. It caches the routing information to permit an

1711

error report."))

1712

1713

(defclass terminate-request (task)

1714

())

1715

1716

(defclass store-error-task (store-data-task error-task)

1717

()

1718

(:documentation "A store-error-task is a stub to comprise the initial information reported back from

1719

    a store when a remote error occurs. It serves as the task argument to error logging and response

1720

generation."))

1721

1722

(defclass query-error-task (data-task error-task)

1723

()

1724

(:documentation "A query-error-task is a stub to comprise the initial query properties and the

1725

error condition. It serves as the task argument to error logging and response generation."))

1726

1727

(defgeneric request-signature (task)

1728

(:documentation "Return the sha1 ignature of a query expression. Given a query, this

1729

is either specified when it is created or computed on-the-fly. Given a string,

1730

it is the sha1 of the string minus any white-space. If no query text is available,

1731

the value is the empty string.")

1732

(:method ((task task))

1733

(or (get-task-request-signature task)

1734

(setf (task-request-signature task)

1735

(request-signature (task-request-content task)))))

1736

(:method ((buffer null))

1737

"")

1738

(:method ((buffer string))

1739

(make-sha1-digest (string-trim #(#\space #\return #\newline #\tab) buffer)))

1740

(:method ((query query-error-task))

1741

""))

1742

(defun query-signature (object)

1743

(request-signature object))

1744

(defun (setf query-signature) (signature object)

1745

(setf (task-request-signature object) signature))

1746

1747

(defmethod query-sparql-expression ((query query-error-task))

1748

"")

1749

(defmethod task-state ((query query-error-task))

1750

:terminate)

1751

1752

(macrolet ((def-task-metadata-property (name)

1753

(let ((operator-name (cons-symbol :spocq.i :task- name))

1754

(metadata-operator-name (cons-symbol :spocq.i :metadata- name)))

1755

`(progn

1756

(defgeneric ,operator-name (metadata)

1757

                     (:method ((task task)) (,metadata-operator-name (instance-metadata task))))

1758

(defgeneric (setf ,operator-name) (value metadata)

1759

                     (:method (value (task task)) (setf (,metadata-operator-name (instance-metadata task)) value)))))))

1760

(def-task-metadata-property api-key)

1761

(def-task-metadata-property solution-limit)

1762

(def-task-metadata-property time-limit))

1763

1764

(defmethod task-api-key ((task null))

1765

nil)

1766

1767

(defmethod task-start-time ((task null))

1768

"Outside of a task context, return the current universal time"

1769

(get-universal-time))

1770

1771

(defmethod (setf metadata-provenance-repository-id) :before (id (repository repository))

1772

(etypecase id

1773

(string

1774

(or (string-equal id "nil")

1775

(assert (equalp (repository-account-name id) (repository-account-name repository)) ()

1776

                  "Invalid provenance relation between base and provenance repositories: ~s, ~s"

1777

repository id)))

1778

(null )))

1779

1780

1781

(defgeneric get-all-task-transactions (task)

1782

(:method ((task task))

1783

(typecase (task-transactions task)

1784

(sb-concurrency:mailbox (channel-get-all (task-transactions task)))

1785

(t (bt:with-lock-held ((task-lock task))

1786

(shiftf (task-transactions task) nil))))))

1787

1788

(defgeneric transaction-task (transaction)

1789

(:method ((transaction transaction))

1790

(find-query (transaction-task-id transaction))))

1791

1792

(defgeneric task-close-transactions (task &key disposition)

1793

(:method ((task task) &key (disposition nil))

1794

(loop for transaction in (get-all-task-transactions *task*)

1795

when (and (eq transaction (task-transaction task)) (transaction-open-p transaction))

1796

do (progn

1797

(transaction-close transaction disposition)

1798

(log-debug "task-close-transactions: transaction closed ~s ~s"

1799

transaction disposition)))))

1800

1801

(defgeneric task-dataset-transaction (task identifier)

1802

(:documentation "Search through the parent chain for a transaction known for the respective revision.

1803

If none is found return nil")

1804

(:method ((task null) (revision-id string))

1805

nil)

1806

(:method ((task task) (revision-id string))

1807

(flet ((return-if-found (transaction)

1808

(when (equal (transaction-revision-id transaction) revision-id)

1809

(return-from task-dataset-transaction transaction))))

1810

(map-channel #'return-if-found (task-transactions task))

1811

(task-dataset-transaction (task-parent-task task) revision-id)))

1812

(:method ((task t) (revision repository-revision))

1813

(task-dataset-transaction task (repository-revision-id revision))))

1814

1815

(defgeneric set-task-dataset-transaction (task transaction)

1816

(:method ((task task) (transaction transaction))

1817

(let ((transactions (task-transactions task))

1818

(revision-id (transaction-revision-id transaction)))

1819

(flet ((error-if-found (found-transaction)

1820

(when (equal (transaction-revision-id found-transaction) revision-id)

1821

(error "duplicate transaction for a revision: ~s: ~s, ~s"

1822

revision-id found-transaction transaction))))

1823

(map-channel #'error-if-found transactions)

1824

(channel-put transactions transaction)

1825

transaction))))

1826

1827

(defgeneric task-transaction (data-task)

1828

(:documentation "Return the task's primary transaction instance.

1829

This wraps the store transaction record.

1830

    If there is none available from a parent task, It is generated on-demand and owned by the immediate task.

1831

If created, at that point the access is authorized for the respective task operation -

1832

both in general, for the processor's general api settings and for the specific repository.")

1833

1834

(:method ((task data-task))

1835

(flet ((ensure-transaction ()

1836

(or (get-task-transaction task)

1837

                  (setf-task-transaction (ensure-task-dataset-transaction task (task-revision task) (task-access-mode task))

1838

task))))

1839

(let ((lock (task-lock task)))

1840

(if (eq (sb-thread:mutex-owner lock) (bt:current-thread))

1841

(ensure-transaction)

1842

(bt:with-lock-held (lock) (ensure-transaction)))))))

1843

1844

1845

(defgeneric make-task-transaction (task revision access-mode)

1846

(:method ((task task) (revision repository-revision) (access-mode t))

1847

(if (api-authorized-p *api-access-mode* access-mode)

1848

(if (or (access-authorized-p revision (task-agent task) access-mode)

1849

(let* ((parent (task-parent-task task)))

1850

(when parent

1851

                     (or (access-authorized-p revision (repository-account (task-repository parent)) access-mode)

1852

                         (access-authorized-p revision (task-request-location parent) access-mode)))))

1853

(let ((transaction (repository-make-transaction revision

1854

                                                             :operation (task-operation task)

1855

                                                             :api-key (metadata-api-key task)

1856

                                                             ;; record the task ownership

1857

                                                             :read-only-p (case access-mode

1858

                                                                            ((|acl|:|Read| |acl|:|Execute|) t)

1859

                                                                            (t nil))

1860

                                                             :task task)))

1861

;; do not retain the transaction instance as that can cause memory-issues.

1862

;; ndone now insteac as part of transaction closing with a double-check when

1863

;; the task completes in the finalize-task operator

1864

#+(and sbcl nil)

1865

(progn

1866

                 (sb-ext:finalize task #'(lambda () (when transaction (destroy-transaction transaction))))

1867

;; this variation eliminates the closure, but sill eventually fails

1868

                 (sb-ext:finalize task (eval `(function (lambda () (destroy-transaction ,transaction))))))

1869

transaction)

1870

(spocq.e:task-authorization-error :task task :operation (task-operation task)))

1871

(spocq.e:api-authorization-error :task task :operation (task-operation task)))))

1872

1873

(defgeneric ensure-task-dataset-transaction (task revision access-mode)

1874

(:method ((task task) (revision repository-revision) (access-mode t))

1875

(when (find (repository-id revision) *disabled-repositories* :test #'string-equal)

1876

(error 'spocq.e:runtime-error

1877

:query nil

1878

              :expression (format nil "The repository has been disabled: ~s." (repository-id revision))))

1879

(or (task-dataset-transaction task revision)

1880

(set-task-dataset-transaction task (make-task-transaction task revision access-mode)))))

1881

1882

(defgeneric task-transaction-disposition (task)

1883

   (:documentation "Return the normal disposition for write transactions within the extend of the given task")

1884

(:method ((task null))

1885

;; for the case, where no task is active

1886

:commit))

1887

1888

(defun make-data-task (&rest args)

1889

(declare (dynamic-extent args))

1890

(apply #'make-instance *class.data-task* args))

1891

1892

(defun call-with-task (operator &rest args &key (id (make-v1-uuid-string)) &allow-other-keys)

1893

(declare (dynamic-extent args))

1894

(let ((*task* (apply #'make-task :id id args)))

1895

(funcall operator *task*)))

1896

1897

1898

;;; primary interface operators

1899

;;; call-with-task-environment : during query processing

1900

;;; call-with-open-repository : autonomous transactions

1901

1902

(defgeneric call-with-task-environment (operator task &key normal-disposition abnormal-disposition)

1903

(:argument-precedence-order task operator)

1904

(:method :around ((operator function) (task task) &rest args)

1905

(declare (function operator)

1906

(ignore args))

1907

(if (eq *task* task)

1908

(funcall operator)

1909

(let ((*task* task) (*agent* (task-agent task)))

1910

(call-next-method))))

1911

1912

(:method ((operator function) (task task) &rest args)

1913

(declare (function operator)

1914

(ignore args))

1915

(let ((*task-indices* (task-indices task)))

1916

(with-accounting

1917

(call-with-metadata-bound operator task))))

1918

1919

(:method ((operator function) (task data-task) &rest args)

1920

"bind the task caches, intern and bind any dynamic variables;

1921

then call the function within the dynamic extent of an open transaction"

1922

(declare (dynamic-extent args))

1923

(let ((*lexical->spocq-term-registry* (task-lexical->spocq-term-registry task))

1924

(*spocq->store-term-registry* (task-spocq->store-term-registry task))

1925

(*store->spocq-term-registry* (task-store->spocq-term-registry task))

1926

(bindings (query-dynamic-bindings task)))

1927

(with-repository (task-repository task)

1928

(flet ((call-next-method-with-bindings (transaction)

1929

(declare (ignore transaction))

1930

(if bindings

1931

(progv (first bindings)

1932

(loop for value in (rest bindings)

1933

                               collect (repository-object-term-number *repository* value))

1934

(call-next-method))

1935

(call-next-method))))

1936

(declare (dynamic-extent #'call-next-method-with-bindings))

1937

(multiple-value-prog1 (apply #'call-with-revision-transaction

1938

#'call-next-method-with-bindings

1939

                                        (task-revision task) (task-transaction task)

1940

args)

1941

#+(or)

1942

;; do not clear the transaction as it figures in post-processing

1943

;; the record is destroyed when it closes w/ commit or abort

1944

(unless (transaction-record (task-transaction task))

1945

(setf-task-transaction nil task)))))))

1946

1947

(:method (operator (query query) &rest args)

1948

(declare (ignore args))

1949

(let* ((*query* query)

1950

(*task-operation* (first (query-sse-expression query))))

1951

(call-next-method))))

1952

1953

1954

1955

;;;

1956

1957

(defclass rule-library ()

1958

((name :initarg :name :reader rule-library-name :writer setf-rule-library-name)

1959

(path :initform (error "path is required") :initarg :path :accessor rule-library-path)

1960

(repositories :reader rule-library-repositories :writer setf-rule-library-repositories)

1961

    (repository-timestamps :initform nil :reader rule-library-repository-timestamps :writer setf-rule-library-repository-timestamps)

1962

(ask-rules :initform (make-hash-table :test #'equalp) :reader rule-library-ask-rules)

1963

(construct-rules :initform (make-hash-table :test #'equalp) :reader rule-library-construct-rules)

1964

(update-rules :initform (make-hash-table :test #'equalp) :reader rule-library-update-rules)

1965

(groups :initform (make-hash-table :test #'equalp) :reader rule-library-groups))

1966

(:documentation

1967

"Encapsulate a list of library repoistories and provide operations to load rules."))

1968

1969

(defmethod initialize-instance ((instance rule-library) &rest initargs

1970

&key path)

1971

(let ((repositories (remove nil

1972

(loop for location in path

1973

collect (or (typecase location

1974

                                                (string (repository location))

1975

                                                (iri (let ((id (iri-service-repository-id location)))

1976

(when id

1977

                                                         (repository id))))

1978

(t nil))

1979

(progn

1980

                                                (log-warn "rule-library-repositories: invalid location: ~s" location)

1981

nil))))))

1982

(setf-rule-library-repositories repositories instance)

1983

(setf-rule-library-name (rule-library-name (mapcar #'repository-id repositories)) instance)

1984

(apply #'call-next-method instance

1985

initargs)))

1986

1987

1988

(defgeneric rule-library-name (library)

1989

(:method ((library null))

1990

nil)

1991

(:method ((path cons))

1992

(format nil "~{~a~^+~}" path)))

1993

1994

(defgeneric ensure-rule-library (path)

1995

#+(or)(:method :around ((path t))

1996

(print (list :around path))

1997

(break)

1998

(call-next-method))

1999

(:method ((path string))

2000

(ensure-rule-library (iri-sequence-value path)))

2001

(:method ((path cons))

2002

(flet ((coerce-to-id (element)

2003

(or (iri-service-repository-id element)

2004

(error "ensure-rule-library: invalid path: ~s" path))))

2005

(declare (dynamic-extent #'coerce-to-id))

2006

(let ((name (rule-library-name (mapcar #'coerce-to-id path))))

2007

(cond ((get-registry name *library-registry*))

2008

(t

2009

(setf (get-registry name *library-registry*)

2010

(make-instance 'rule-library :path path :name name))))))))

2011

2012

(defgeneric update-rule-library (rule-library)

2013

(:method ((library rule-library))

2014

(let ((timestamps (mapcar #'repository-write-timestamp (rule-library-repositories library))))

2015

(unless (equal timestamps (rule-library-repository-timestamps library))

2016

(setf-rule-library-repository-timestamps timestamps library)

2017

(load-rule-library library)))

2018

library))

2019

2020

;;;

2021

2022

(defclass intermediate ()

2023

((solutions :initform nil :reader get-intermediate-solutions :writer (setf intermediate-solutions))

2024

(variables :initform nil :initarg :variables :accessor intermediate-variables)

2025

(bindings :initform nil :initarg :bindings :accessor intermediate-bindings)

2026

(successors :initform nil :accessor intermediate-successors)))

2027

2028

(defclass agp (intermediate)

2029

((id :initarg :id :reader agp-id)

2030

(query :initform nil :initarg :query :reader agp-query)

2031

(repository :initarg :repository :reader get-agp-repository :writer setf-agp-repository)

2032

(state :initform :initialize :accessor agp-state :type (member :initialize :delegate :complete))

2033

(body :initarg :body :reader agp-body)

2034

(bindings

2035

:initform nil :initarg :bindings :accessor agp-bindings

2036

:documentation "A solution field with bindings which are to be processed with the agp")

2037

(projection-dimensions :initform nil :initarg :projection-dimensions :accessor agp-projection-dimensions)

2038

(graph :initform nil :initarg :graph :accessor agp-graph)

2039

(statements :initform nil :initarg :statements :accessor agp-statements)

2040

(declarations :initform nil :initarg :declarations :accessor agp-declarations)

2041

(filters :initform nil :initarg :filters :accessor agp-filters)

2042

(binds

2043

:initform nil :initarg :binds :accessor agp-binds

2044

:documentation "a list of bind forms which have been pushed into the bgp")

2045

(slice :initform nil :initarg :slice :accessor agp-slice)

2046

(dataset-graphs :initform nil :initarg :dataset-graphs :accessor agp-dataset-graphs)

2047

(join-scope :initform nil :initarg :join-scope :accessor agp-join-scope)

2048

(base-dimensions :initform nil :initarg :base-dimensions :accessor agp-base-dimensions)

2049

(base-channel :initform nil :accessor agp-base-channel)

2050

(result-channels :initform nil :accessor agp-result-channels)

2051

(solutions :initform nil :reader get-agp-solutions :writer setf-agp-solutions)

2052

(variables :initarg :variables :reader agp-variables)

2053

(reference-dimensions :initarg :reference-dimensions :reader agp-reference-dimensions)

2054

(equivalents :initarg :equivalents :initform nil :reader agp-equivalents)

2055

(resources :initarg :resources :reader agp-resources)

2056

(predecessors :initform nil :accessor agp-predecessors)

2057

(successors :initform nil :accessor agp-successors)

2058

(store-class :reader agp-store-class :allocation :class)

2059

(processing-mode :initarg :processing-mode :initform :asynchronous

2060

:reader agp-processing-mode

2061

:type (member :synchronous :asynchronous))

2062

(pattern-functions

2063

:initform nil :initarg :pattern-functions

2064

:accessor agp-pattern-functions

2065

:documentation "A p-list (repo function) which caches the match functions per repository.

2066

      It is initially empty and function are computed and compiled on demand, as the agp solutions are required.")

2067

(start-time

2068

:initform 0

2069

:accessor agp-start-time

2070

:documentation "Record the thread start time for the pattern match.")

2071

(end-time

2072

:initform 0

2073

:accessor agp-end-time

2074

:documentation "Record the thread start time for the pattern match.")

2075

(field-size-estimate

2076

:initform 1

2077

:accessor agp-field-size-estimate

2078

:documentation "An estmate of the field size (solutions x dimensions) to

2079

contribute to execution ordering.")

2080

(solution-count

2081

:initform 0

2082

:accessor agp-solution-count

2083

:documentation "Save the matched solution count at the end of matching.")

2084

(temporal-binds

2085

:initform nil :initarg :temporal-binds :initarg :temporal-constraints

2086

:accessor agp-temporal-binds

2087

:documentation "a list of bind pairs for temporal values")

2088

(version-constraints

2089

:initform nil :initarg :version-constraints

2090

:accessor agp-version-constraints)

2091

#+(or) ;; not possible: the environment had dynamic extent

2092

(environment

2093

:initform nil :initarg :environment

2094

:accessor agp-environment

2095

:documentation "Captures the query compile-time environment in which the agp was

2096

instantiated in order to apply declarations when the bgp match function is

2097

compiled."))

2098

(:documentation "An AGP is an augmented graph pattern. It combines the triple patterns

2099

of a basic graph pattern with annotation and cache information used to optimize the

2100

pattern matching."))

2101

2102

(defclass delegated-agp (agp)

2103

((store-class :initform nil :allocation :class))

2104

(:documentation "A delegated agp passes the graph pattern to a remote resource for processing.

2105

  Where bindings are propagated, these are passed as well. Whenever the result arrives, it is bound to the agp

2106

and made available for reduction."))

2107

2108

(defclass amqp-agp (delegated-agp)

2109

())

2110

2111

(defclass retained-agp (agp)

2112

()

2113

(:documentation "A retained agp interprets the graph pattern directly against a local store"))

2114

2115

(defclass rdfcache-agp (retained-agp)

2116

((store-class :initform 'rdfcache :allocation :class)))

2117

2118

(defclass hashcache-agp (retained-agp)

2119

())

2120

2121

;;;

2122

2123

(:documentation

2124

"The abstract task initialization copies the operation and the arguments

2125

from the message, and extracts required fields and options. The specific task initialization

2126

does the same for specialized options and initializes specialized exprssions from the

2127

general argument list. The message options are not retained intact.")

2128

2129

(defgeneric task-elapsed-time (task)

2130

(:method ((task task))

2131

(- (get-internal-real-time) (task-start-real-time task))))

2132

2133

;;;

2134

;;; instantiation initialization and clone operators

2135

2136

2137

(defmethod initialize-instance ((instance object-with-metadata) &rest initargs &key

2138

(metadata nil m-s))

2139

"a cloned instance w/metadata gets metadata from the current global state extended with additions."

2140

(declare (dynamic-extent initargs))

2141

(apply #'call-next-method instance

2142

initargs)

2143

(when m-s

2144

(setf-instance-metadata (when metadata

2145

                               (apply #'clone-instance metadata :allow-other-keys t initargs))

2146

instance)))

2147

2148

(defmethod initialize-clone ((old object-with-metadata) (new object-with-metadata) &rest initargs &key

2149

(metadata (_slot-value old 'metadata)))

2150

"a cloned instance w/metadata gets cloned metadata extended with additions."

2151

(declare (dynamic-extent initargs))

2152

(log-debug "initialize-clone: object-with-metadata")

2153

(apply #'call-next-method old new

2154

:metadata (when metadata (apply #'clone-instance metadata :allow-other-keys t initargs))

2155

initargs))

2156

2157

2158

 (defmethod initialize-clone ((old object-with-persistent-metadata) (new object-with-persistent-metadata) &rest initargs &key

2159

(identifier (_slot-value old 'identifier)))

2160

"a cloned instance w/persistent metadata copies the identifier extended with additions."

2161

(declare (dynamic-extent initargs))

2162

(apply #'call-next-method old new

2163

:identifier identifier

2164

initargs))

2165

2166

2167

(defmethod initialize-instance ((instance task) &rest initargs

2168

                                 &key (accept *response-content-type*) (content-type accept)

2169

(response-content-type content-type)

2170

id (request-routing-key id)

2171

(agent-id *agent-id*)

2172

(agent-location *agent-location*)

2173

(agent (or *agent*

2174

(ensure-agent :name agent-id

2175

                                                          :location agent-location)))

2176

(thread (bt:current-thread)))

2177

(declare (dynamic-extent initargs))

2178

(etypecase response-content-type

2179

(null )

2180

(cons (setf response-content-type (mime:mime-type (first response-content-type))))

2181

(t (setf response-content-type (mime:mime-type response-content-type))))

2182

;;;!!! for query+sse client which cannot handle null result values

2183

;;;(setf content-type mime:application/octet-stream)

2184

(let ((name-string (with-output-to-string (stream)

2185

(print-unreadable-object (instance stream :identity t :type t)

2186

(format stream "~:[?~;~:*~a~]" id)))))

2187

(setf (slot-value instance 'lock) (bt:make-lock name-string)

2188

(slot-value instance 'thread-task-semaphore) (sb-thread:make-semaphore :name name-string))

2189

(setf (slot-value instance 'statistics) (make-pool :name "task statistics"))

2190

(setf (slot-value instance 'errors) (make-pool :name "task errors"))

2191

(setf (slot-value instance 'operations) (make-pool :name "task operations"))

2192

(setf (slot-value instance 'transactions) (make-pool :name "task transactions")))

2193

2194

(apply #'call-next-method instance

2195

:agent agent

2196

:thread thread

2197

:response-content-type response-content-type

2198

:request-routing-key request-routing-key

2199

initargs))

2200

2201

(defmethod print-object ((object task) (stream t) &aux (*print-pretty* nil))

2202

(_print-unreadable-object (object stream :type t :identity t)

2203

(format stream "[~a(~@[~a~].~@[~a~]), ~a@~a]"

2204

(bound-slot-value object 'id)

2205

(bound-slot-value object 'name)

2206

(bound-slot-value object 'user-id)

2207

(bound-slot-value object 'operation)

2208

(bound-slot-value object 'state))))

2209

2210

(defmethod initialize-clone ((old task) (new task) &rest initargs &key

2211

task-id

2212

                              ;; as a default, the agent is constructed from the immediate

2213

                              ;; configuration state rather than carried over from the

2214

;; prototype

2215

(agent-id *agent-id*)

2216

(agent-location *agent-location*)

2217

(agent (or *agent*

2218

(ensure-agent :name agent-id

2219

                                                       :location agent-location)))

2220

(thread (bt:current-thread))

2221

(operation (_slot-value old 'operation))

2222

(request-exchange (_slot-value old 'request-exchange))

2223

(state (_slot-value old 'state))

2224

                              (response-content-type (_slot-value old 'response-content-type))

2225

                              (request-content-type (_slot-value old 'request-content-type))

2226

(request-content (_slot-value old 'request-content))

2227

signature

2228

                              (request-signature (or signature (_slot-value old 'request-signature)))

2229

(operator-count (_slot-value old 'operator-count))

2230

(indices (copy-task-indices (_slot-value old 'indices)))

2231

(dynamic-bindings (_slot-value old 'dynamic-bindings))

2232

(properties (_slot-value old 'properties)))

2233

;; id, user-id must be supplied

2234

;; time-related slots are renewed

2235

(let ((name-string (with-output-to-string (stream)

2236

(print-unreadable-object (new stream :identity t :type t)

2237

(format stream "~:[?~;~:*~a~]" task-id)))))

2238

(setf (slot-value new 'lock) (bt:make-lock name-string)

2239

(slot-value new 'thread-task-semaphore) (sb-thread:make-semaphore :name name-string))

2240

(setf (slot-value new 'statistics) (make-pool :name "task statistics"))

2241

(setf (slot-value new 'errors) (make-pool :name "task errors"))

2242

(setf (slot-value new 'threads) (make-registry :test 'equal))

2243

(setf (slot-value new 'operations) (make-pool :name "task operations"))

2244

(setf (slot-value new 'transactions) (make-pool :name "task transactions")))

2245

(log-debug "init cloned task: ~s (~s: ~s)" task-id agent operation)

2246

(apply #'call-next-method old new

2247

:agent agent

2248

:thread thread

2249

:operation operation

2250

:request-exchange request-exchange

2251

:state state

2252

:request-content request-content

2253

:request-signature request-signature

2254

;; cloning lost parameters

2255

          :request-content-type request-content-type ;; do not clone (when request-content-type (mime-type request-content-type))

2256

          :response-content-type response-content-type ;; do not clone (when response-content-type (mime-type response-content-type))

2257

:operator-count operator-count

2258

:indices indices

2259

:dynamic-bindings dynamic-bindings

2260

:properties properties

2261

:transactions ()

2262

initargs))

2263

2264

(defgeneric task-complete-p (task)

2265

(:method ((task task))

2266

(eq (task-state task) :complete)))

2267

2268

(defgeneric task-active-p (task)

2269

(:documentation "Return true iff the currrent task is still running.

2270

If no task is present, this is some sort of background processing for

2271

which always return true.")

2272

(:method ((task task))

2273

(case (task-state task)

2274

((:terminated :terminate :complete :finalized) nil)

2275

(t t)))

2276

(:method ((task null)) t))

2277

2278

(defgeneric update-task-state (task state)

2279

(:method ((task task) state)

2280

(when (task-active-p task)

2281

(setf (task-state task) state)))

2282

(:method ((task null) state)

2283

(log-warn "update-ask-state: null task update to state: ~s." state)))

2284

;; (defmethod update-task-state (task (state (eql :terminate))) (break "@terminate") (call-next-method))

2285

;; (defmethod (setf task-state) :before ((state (eql :terminate)) (task t)) (break "@terminate"))

2286

2287

2288

(defmethod initialize-instance ((instance data-task) &rest initargs &key

2289

                                 ;; if the properties are not given, a message must be present

2290

(repository-id nil)

2291

(revision-id nil)

2292

(repository-class nil repository-class-sp)

2293

(revision-class nil revision-class-sp)

2294

                                 (repository (when repository-id (repository repository-id)))

2295

(revision (when repository

2296

                                             (repository-revision revision-id :reference repository

2297

                                                                  :class (repository-revision-class repository))))

2298

(dataset-graphs nil)

2299

                                 (lexical->spocq-term-registry (copy-registry *lexical->spocq-term-registry*))

2300

                                 (spocq->store-term-registry (copy-registry *spocq->store-term-registry*))

2301

                                 (store->spocq-term-registry ;; w/ the sbcl hash table implementation, this

2302

;; causes times to degrade

2303

                                  ;; (repository-store->spocq-term-registry repository)

2304

(copy-registry *store->spocq-term-registry*))

2305

)

2306

"Given the combination of revision-id, revision, repository-id and/or repository,

2307

resolve both the repository and the revision and save the revision-id as revision-designator

2308

for future resolution steps"

2309

(declare (dynamic-extent initargs))

2310

   (when repository-class-sp (log-warn "initialize-instance(data-task): repository-class ignored for repository: ~s ~s" repository-class repository))

2311

   (when revision-class-sp (log-warn "initialize-instance(data-task): revision-class ignored for repository: ~s ~s" revision-class repository))

2312

(setf-task-lexical->spocq-term-registry lexical->spocq-term-registry instance)

2313

(setf-task-spocq->store-term-registry spocq->store-term-registry instance)

2314

(setf-task-store->spocq-term-registry store->spocq-term-registry instance)

2315

;; ephemeral terms must be new, as unregister-query destroys the content.

2316

;; (setf-task-ephemeral-terms (repository-make-ephemeral-term-cache repository) instance)

2317

(etypecase revision-id

2318

(string)

2319

(spocq:uuid (setf revision (spocq:uuid-lexical-form revision-id)))

2320

(null (setf revision-id "HEAD")))

2321

(apply #'call-next-method instance

2322

:repository repository

2323

:revision revision

2324

:revision-id revision-id

2325

:dataset-graphs dataset-graphs

2326

initargs)

2327

(log-debug "inited new data-task: ~s (~s: ~s): ~s" repository revision-id revision instance))

2328

2329

2330

(defmethod initialize-instance :after ((instance data-task) &key)

2331

(unless (metadata-base-iri instance)

2332

(setf (metadata-base-iri instance)

2333

(let ((repository (task-repository instance)))

2334

(if repository

2335

(repository-uri repository)

2336

(site-namespace))))))

2337

2338

2339

(defmethod print-object ((object data-task) (stream t) &aux (*print-pretty* nil))

2340

(_print-unreadable-object (object stream :type t :identity t)

2341

(format stream "[~a/~a, ~a@~a, ~a@~a]"

2342

(bound-slot-value object 'id)

2343

(bound-slot-value object 'user-id)

2344

(bound-slot-value object 'operation)

2345

(bound-slot-value object 'state)

2346

(let ((r (bound-slot-value object 'repository)))

2347

(when r (repository-id r)))

2348

(bound-slot-value object 'revision-id))))

2349

2350

(defmethod initialize-clone ((old data-task) (new data-task) &rest initargs &key

2351

(account (_slot-value old 'account))

2352

(repository (_slot-value old 'repository) repository-s)

2353

(revision-class (repository-revision-class repository))

2354

                              (revision-id (_slot-value old 'revision-id) revision-id-s)

2355

                              (revision (repository-revision revision-id :reference repository) revision-s)

2356

(result-generator (_slot-value old 'result-generator))

2357

                              (initialization-function (_slot-value old 'initialization-function))

2358

(dataset-graphs (_slot-value old 'dataset-graphs))

2359

(priority (_slot-value old 'priority))

2360

(start-time (get-universal-time))

2361

(end-time (_slot-value old 'end-time))

2362

(time-interval (_slot-value old 'time-interval))

2363

                              (lexical->spocq-term-registry (copy-registry (_slot-value old 'lexical->spocq-term-registry)))

2364

                              (spocq->store-term-registry (copy-registry (_slot-value old 'spocq->store-term-registry)))

2365

                              (store->spocq-term-registry (copy-registry (_slot-value old 'store->spocq-term-registry))))

2366

"Clone a data-task by copying most field.

2367

    For the revision, unless a specific one is supplied, resolve it anew from the repository base on the revision id

2368

which was saved as at initialization"

2369

; double-check association

2370

(assert (equal (repository-id repository) (repository-id (_slot-value old 'repository))) ()

2371

"Invalid cloned repository : ~s != ~s" repository (_slot-value old 'repository))

2372

   (assert (equal (repository-id (repository-revision-reference revision)) (repository-id (_slot-value old 'repository))) ()

2373

           "Invalid cloned revision : ~s !-> ~s (supplied ~s/~s/~s)" revision (_slot-value old 'repository)

2374

repository-s revision-id-s revision-s)

2375

(setf (task-result-generator new) result-generator)

2376

(setf (task-initialization-function new) initialization-function)

2377

;; clear the transaction in order to cause the current api and agent to apply

2378

;; when a new one is created. also to track any revision change

2379

(setf-task-transaction nil new)

2380

(setf-task-lexical->spocq-term-registry lexical->spocq-term-registry new)

2381

(setf-task-spocq->store-term-registry spocq->store-term-registry new)

2382

(setf-task-store->spocq-term-registry store->spocq-term-registry new)

2383

(log-debug "init clone data-task: ~s ~s" repository account)

2384

(apply #'call-next-method old new

2385

:account account

2386

:repository repository

2387

:revision-class revision-class

2388

:revision-id revision-id

2389

:revision revision

2390

:dataset-graphs dataset-graphs

2391

:priority priority

2392

:start-time start-time

2393

:end-time end-time

2394

:time-interval time-interval

2395

initargs))

2396

2397

(defun make-task (&rest args)

2398

(declare (dynamic-extent args))

2399

(apply #'make-instance *class.task* args))

2400

2401

(defmethod initialize-instance ((instance query) &rest initargs &key

2402

sse-expression

2403

(operation (first sse-expression))

2404

(request-values *request-values*)

2405

(describe-properties *describe-properties* dp-p)

2406

(library-path (library-path))

2407

(library nil))

2408

(setf library (etypecase library

2409

(null (typecase library-path

2410

((or string cons) (ensure-rule-library library-path))

2411

(t nil)))

2412

(rule-library library)

2413

(string (ensure-rule-library library))))

2414

(when library (log-debug "query: library: ~s ~s" library-path library))

2415

(apply #'call-next-method instance

2416

:operation operation

2417

:library library

2418

initargs)

2419

;; ensure that the library is compiled

2420

(when library

2421

(update-rule-library library)

2422

(graph-rewrite-processor library (task-repository instance)))

2423

(setf (task-property instance :request-values) request-values)

2424

(when (or describe-properties dp-p)

2425

(setf (task-property instance :describe-properties) describe-properties)))

2426

2427

#|

2428

 #+(or)                                ; disabled in favor of loading extension entities on demand

2429

(let ((rule-sets (metadata-rule-sets instance)))

2430

(when rule-sets

2431

(let ((sets (loop with repository = (task-repository instance)

2432

for rule-set in rule-sets

2433

for rules = (repository-rule-set repository rule-set)

2434

collect (make-instance 'rule-set

2435

:iri rule-set

2436

:rules rules

2437

:rule-expressions rules))))

2438

(setf (query-pattern-rewrite-rule-sets instance) sets))))

2439

|#

2440

2441

(defmethod initialize-clone ((old query) (new query) &rest initargs &key

2442

(sse-expression (_slot-value old 'sse-expression))

2443

(patterns (_slot-value old 'patterns))

2444

(variables (_slot-value old 'variables))

2445

                              #|(pattern-rewrite-rule-sets (_slot-value old 'pattern-rewrite-rule-sets))

2446

                              (pattern-rewrite-operator (_slot-value old 'pattern-rewrite-operator))|#

2447

(library (_slot-value old 'library))

2448

(license (_slot-value old 'license))

2449

(request-values *request-values*)

2450

(describe-properties *describe-properties* dp-p)

2451

)

2452

(apply #'call-next-method old new

2453

:sse-expression sse-expression

2454

:patterns patterns

2455

:variables variables

2456

;;:pattern-rewrite-rule-sets pattern-rewrite-rule-sets

2457

;;:pattern-rewrite-operator pattern-rewrite-operator

2458

:library library

2459

:license license

2460

initargs)

2461

;; always set

2462

(setf (task-property new :request-values) request-values)

2463

(when (or describe-properties dp-p)

2464

(setf (task-property new :describe-properties) describe-properties)))

2465

2466

(defgeneric make-query (object &rest args)

2467

(:method ((object symbol) &rest args)

2468

(declare (dynamic-extent args))

2469

(apply #'make-instance *class.query* object args))

2470

(:method ((object string) &rest args)

2471

(declare (dynamic-extent args))

2472

(apply #'make-query :sse-expression (parse-sparql object) args))

2473

(:method ((object cons) &rest args)

2474

(declare (dynamic-extent args))

2475

(apply #'make-query :sse-expression object args)))

2476

2477

(defun make-script (&rest args)

2478

(declare (dynamic-extent args))

2479

(apply #'make-instance *class.sparql-script* args))

2480

2481

(defun make-service-query (&rest args)

2482

(declare (dynamic-extent args))

2483

(apply #'make-instance 'service-query args))

2484

2485

(defmethod initialize-instance ((instance bgp-match) &rest initargs

2486

&key

2487

arguments

2488

(dataset-graphs (getf arguments :dataset-graphs)))

2489

(apply #'call-next-method instance

2490

:dataset-graphs dataset-graphs

2491

initargs))

2492

2493

2494

(defmethod expression-variables ((agp agp))

2495

(nconc (mapcar #'first (agp-equivalents agp)) (agp-variables agp)))

2496

2497

(defmethod initialize-instance ((instance agp) &rest initargs

2498

&key (query *query*) body

2499

                                 (id (or (second (assoc 'spocq.a::|id| body)) (gensym "AGP-")))

2500

(dataset-graphs nil dg-s)

2501

                                 (projection-dimensions (bgp-projected-dimensions body)))

2502

(let* ((filters (remove-if-not #'filter-form-p body))

2503

(slice (rest (assoc 'spocq.a:|slice| body)))

2504

(graph (second (assoc 'spocq.a:|graph| body)))

2505

(equivalents (rest (assoc 'spocq.a:|equivalents| body)))

2506

(default-graph-term (assoc 'spocq.a:|from| body))

2507

(named-graph-term (assoc 'spocq.a:|from-named| body))

2508

(triples (remove-if-not #'bgp-statement-form-p body))

2509

(binds (remove-if-not #'bind-form-p body))

2510

(variables (expression-variables body))

2511

(resources (expression-resources body)))

2512

2513

;; (print (list :body body :pd projection-dimensions))

2514

(apply #'call-next-method instance

2515

:id id

2516

:form body

2517

:graph graph

2518

:declarations (remove-if-not #'declare-form-p body)

2519

:dataset-graphs (cond (dg-s dataset-graphs)

2520

((or named-graph-term default-graph-term)

2521

                                   (make-dataset-graphs :named-graphs (rest named-graph-term)

2522

                                                        :default-graphs (rest default-graph-term)))

2523

(query

2524

(task-dataset-graphs query)))

2525

:statements triples

2526

:filters filters

2527

:binds binds

2528

:slice slice

2529

:variables variables

2530

:equivalents equivalents

2531

:resources resources

2532

:projection-dimensions projection-dimensions

2533

initargs)))

2534

2535

(defmethod initialize-instance ((instance intermediate) &rest initargs

2536

&key (query *query*))

2537

(when query

2538

(push instance (query-patterns query)))

2539

(apply #'call-next-method instance

2540

:query query

2541

initargs))

2542

2543

2544

(defun make-agp (&rest initargs)

2545

(apply #'make-instance *class.agp* initargs))

2546

2547

2548

(defmethod make-load-form ((agp agp) &optional environment)

2549

(make-load-form-saving-slots agp :environment environment))

2550

2551

(defmethod print-object ((object agp) stream)

2552

(_print-unreadable-object (object stream :identity t :type t)

2553

(format stream "~s @~a: ~@[~a->~]~a"

2554

(bound-slot-value object 'id)

2555

(bound-slot-value object 'state)

2556

(bound-slot-value object 'base-dimensions)

2557

(bound-slot-value object 'projection-dimensions))))

2558

2559

2560

2561

;;; metadata instantiation and attribute access

2562

2563

(defgeneric instance-metadata (instance)

2564

(:method ((instance object-with-persistent-metadata))

2565

(let ((existing (call-next-method))

2566

(*agent* (system-agent)))

2567

(unless existing

2568

(setf-instance-metadata (setf existing (make-instance-metadata instance))

2569

instance))

2570

(synchronize-resource existing)

2571

existing)))

2572

2573

2574

(defgeneric make-instance-metadata (instance &rest args)

2575

(:documentation "create a metadata instance respective an owning instance

2576

and synchronize it with the owners stoed metadata values.

2577

For the hierarchical relations

2578

system ->

2579

account ->

2580

repository

2581

the more general context's metadata is used as the default values when

2582

instantiating the specific owning instance's.")

2583

2584

(:method ((instance object-with-metadata) &rest args &key (resource instance))

2585

(declare (dynamic-extent args))

2586

(apply #'make-metadata :resource resource args))

2587

2588

(:method ((account account) &rest args &key (resource account) &allow-other-keys)

2589

(declare (dynamic-extent args))

2590

(if (string-equal "system" (account-name account))

2591

(make-system-account-metadata :resource resource)

2592

(apply #'make-account-metadata :resource resource args)))

2593

2594

(:method ((repository repository) &rest args &key (resource repository) &allow-other-keys)

2595

(declare (dynamic-extent args))

2596

(if (string-equal "system" (repository-name repository))

2597

(make-system-repository-metadata :resource resource)

2598

(apply #'make-repository-metadata :resource resource args)))

2599

2600

(:method :around ((instance object-with-metadata) &rest args

2601

&key (identifier (instance-identifier instance)))

2602

(apply #'call-next-method instance

2603

:identifier identifier

2604

args)))

2605

2606

2607

(defgeneric set-instance-metadata-parameter (instance subject predicate object)

2608

(:method ((instance object-with-metadata) (subject t) (predicate t) (object t))

2609

;; the default method allows for every combination, and tries to set the respective metadata

2610

(when (configuration-setting-p predicate)

2611

(setf (configuration-parameter predicate) object))

2612

object))

2613

2614

(defgeneric instance-metadata-statements (instance)

2615

(:method ((instance object-with-persistent-metadata))

2616

(or (get-instance-metadata-statements instance)

2617

(setf-instance-metadata-statements (read-instance-metadata-statements instance)

2618

instance))))

2619

2620

(defgeneric read-instance-metadata-statements (instance)

2621

(:method :around ((instance object-with-persistent-metadata))

2622

"the around method establishes an error handler to log the condition

2623

and then suppress it."

2624

(handler-bind ((error (lambda (c)

2625

(log-stacktrace "read-instance-metadata: ~a" c)

2626

(return-from read-instance-metadata-statements nil))))

2627

(call-next-method))))

2628

2629

2630

2631

(defmethod instance-repository-id ((instance repository))

2632

(instance-repository-id (repository-account instance)))

2633

2634

;; most all resources devolve to the respective account

2635

(defmethod compute-resource-store-repository-id ((instance account))

2636

(compute-repository-id instance *system-repository-name*))

2637

2638

(defmethod compute-resource-store-repository-id ((instance user))

2639

;; piggy-back on the user's primary account

2640

(compute-repository-id (user-name instance) *system-repository-name*))

2641

2642

(defmethod compute-resource-store-repository-id ((instance repository))

2643

(compute-resource-store-repository-id (repository-account instance)))

2644

2645

2646

(defgeneric instance-metadata-pathname (instance)

2647

(:method ((instance repository))

2648

;; (destructuring-bind (account repository) (split-string (repository-id instance) "/")

2649

     (compute-repository-metadata-pathname (account-name (repository-account instance)) (repository-name instance)))

2650

2651

(:method ((instance service-repository))

2652

(destructuring-bind (scheme host &rest path) (split-string (repository-id instance) "/:")

2653

(let ((directory-name (substitute-if #\_ #'(lambda (c) (not (alphanumericp c)))

2654

                                            (format nil "~{~a~^_~}" (cons host path)))))

2655

(merge-pathnames (make-pathname :directory `(:relative "repositories" ,scheme ,directory-name)

2656

:name *metadata-file-name*

2657

:type *metadata-file-extension*)

2658

*metadata-root-pathname*))))

2659

(:method ((instance account))

2660

(compute-account-metadata-pathname (account-name instance))))

2661

2662

2663

(defun compute-repository-metadata-pathname (account-name repository-name)

2664

(merge-pathnames (make-pathname :directory `(:relative "repositories" ,account-name ,repository-name)

2665

:name *metadata-file-name*

2666

:type *metadata-file-extension*)

2667

*metadata-root-pathname*))

2668

2669

(defun compute-account-metadata-pathname (account-name)

2670

(merge-pathnames (make-pathname :directory `(:relative "accounts" ,account-name)

2671

:name *metadata-file-name*

2672

:type *metadata-file-extension*)

2673

*metadata-root-pathname*))

2674

2675

(defmethod call-with-metadata-bound (op (source object-with-metadata) &rest args)

2676

(declare (dynamic-extent args))

2677

(apply #'call-with-metadata-bound op (instance-metadata source) args))

2678

2679

2680

(defgeneric dataset-default-graphs (context)

2681

(:method ((context list))

2682

(getf context :default-graphs))

2683

(:method ((task data-task))

2684

(getf (task-dataset-graphs task) :default-graphs))

2685

(:method ((agp agp))

2686

(getf (agp-dataset-graphs agp) :default-graphs)))

2687

2688

(defgeneric (setf dataset-default-graphs) (graphs context)

2689

(:method (graphs (context list))

2690

(setf (getf context :default-graphs) graphs))

2691

(:method (graphs (task data-task))

2692

(setf (getf (task-dataset-graphs task) :default-graphs) graphs))

2693

(:method (graphs (agp agp))

2694

(setf (getf (agp-dataset-graphs agp) :default-graphs) graphs)))

2695

2696

(defgeneric dataset-named-graphs (context)

2697

(:method ((context list))

2698

(getf context :named-graphs))

2699

(:method ((task data-task))

2700

(getf (task-dataset-graphs task) :named-graphs))

2701

(:method ((agp agp))

2702

(getf (agp-dataset-graphs agp) :named-graphs)))

2703

2704

(defgeneric (setf dataset-named-graphs) (graphs context)

2705

(:method (graphs (context list))

2706

(setf (getf context :named-graphs) graphs))

2707

(:method (graphs (task data-task))

2708

(setf (getf (task-dataset-graphs task) :named-graphs) graphs))

2709

(:method (graphs (agp agp))

2710

(setf (getf (agp-dataset-graphs agp) :named-graphs) graphs)))

2711

2712

(defun make-dataset-graphs (&key named-graph

2713

(named (when named-graph (list named-graph)))

2714

(named-graphs named)

2715

default-graph

2716

                                  (default (when default-graph (list default-graph)))

2717

(default-graphs default))

2718

;; constraint the keys and reconstruct the list

2719

`(:named-graphs ,named-graphs :default-graphs ,default-graphs))

2720

2721

2722

(defun update-dataset-graphs (specification source)

2723

"modify the dataset spcification subject to precedence rules."

2724

(flet ((collect-dataset (specification)

2725

(if (consp (first specification))

2726

(loop for (key value) in specification

2727

if (member key '(:default-graph :default))

2728

collect value into default

2729

else if (member key '(:named-graph :named))

2730

collect value into named

2731

else do (error "invalid dataset key: ~s." key)

2732

finally (return (when (or default named)

2733

                                      (make-dataset-graphs :default default :named named))))

2734

(loop for (key value) on specification by #'cddr

2735

if (member key '(:default-graph :default))

2736

collect value into default

2737

else if (member key '(:named-graph :named))

2738

collect value into named

2739

else do (error "invalid dataset key: ~s." key)

2740

finally (return (when (or default named)

2741

                                      (make-dataset-graphs :default default :named named)))))))

2742

(ecase source

2743

((:request :configuration)

2744

(setq *dataset-source* source

2745

*dataset-graphs* (collect-dataset specification)))

2746

(:query

2747

(case *dataset-source*

2748

((nil :query :configuration)

2749

(setq *dataset-source* source

2750

*dataset-graphs* (collect-dataset specification)))

2751

(:request

2752

nil))))))

2753

2754

2755

;;; query operators

2756

2757

(defgeneric query (class &rest args)

2758

(:documentation "GIven a class designator instantiate a

2759

     or create a new one and register it in *repositories*. Instantiation relies on the current value

2760

for *class.query* and verifies the result.")

2761

2762

(:method ((designator t) &rest args)

2763

(error "invalid query class designator: ~s . ~s" designator args))

2764

(:method ((class symbol) &rest args)

2765

(declare (dynamic-extent args))

2766

(if (keywordp class)

2767

(apply #'query (find-class *class.query*) class args)

2768

(apply #'query (find-class class) args)))

2769

(:method ((class class) &rest args)

2770

(declare (dynamic-extent args))

2771

(query (apply #'make-instance class args)))

2772

(:method ((query query) &key &allow-other-keys)

2773

query))

2774

2775

(defgeneric query-library (query)

2776

(:documentation "Instantiate a query library on demand to mediate access or a

2777

sequence of rule library repositories")

2778

(:method ((query null))

2779

nil)

2780

(:method ((query query))

2781

(if (slot-boundp query 'library)

2782

(get-query-library query)

2783

(setf (query-library query)

2784

(let ((path (library-path)))

2785

(update-rule-library (ensure-rule-library path)))))))

2786

2787

(defmethod query-entailment-method ((query null))

2788

nil)

2789

2790

(defgeneric task-time (task)

2791

(:method ((task task))

2792

(get-universal-time)))

2793

2794

(defgeneric task-id (context)

2795

(:method ((context null)) *task-id*))

2796

2797

(defun make-task-id ()

2798

"Return a version 1 uuid string see http://www.ietf.org/rfc/rfc4122.txt"

2799

(make-v1-uuid-string))

2800

2801

(defun make-revision-id ()

2802

"Return a version 1 uuid string see http://www.ietf.org/rfc/rfc4122.txt"

2803

(make-v1-uuid-string))

2804

2805

(defun make-internal-task-id ()

2806

"Return a version 1 uuid string, which includes the local node id

2807

See http://www.ietf.org/rfc/rfc4122.txt"

2808

(make-v1-uuid-string))

2809

2810

(defun make-null-task-id ()

2811

"Return a version 1 uuid which is marked as 'null' by clearing the node identifier bytes

2812

to zero. see http://www.ietf.org/rfc/rfc4122.txt"

2813

   ;; causes problems with logging (concatenate 'string (subseq (make-v1-uuid-string) 0 24) "000000000000"))

2814

(make-v1-uuid-string))

2815

2816

(defun make-provenance-task-id (&optional (primary-task-id (or (task-id *task*) "")))

2817

"generate a namespace-relative uuid in the provenance namespace.

2818

by default this incorporates the active task id, otherwise the empty string."

2819

(prin1-to-string (uuid:make-v5-uuid +NAMESPACE-PROVENANCE+ primary-task-id)))

2820

2821

(defun make-service-task-id ()

2822

(make-internal-task-id))

2823

2824

(defgeneric task-user-id (context)

2825

(:method ((context null)) *user-id*))

2826

2827

(defgeneric task-repository-id (task)

2828

(:method ((task null)) *repository-id*)

2829

(:method ((task data-task))

2830

(repository-id (task-repository task))))

2831

2832

(defgeneric task-revision (task)

2833

(:method ((task null)) nil))

2834

2835

(defgeneric query-dynamic-bindings (task)

2836

(:method ((task null)) ()))

2837

2838

;; 2010-10-22 consolidated account and repository into single repository-id

2839

(defgeneric task-query-routing-key (query)

2840

(:method ((task task))

2841

(format nil "~a.~a"

2842

(repository-id task) (task-id task))))

2843

2844

(defgeneric task-store-bgp-routing-key (query)

2845

(:method ((query query))

2846

(or (get-task-store-bgp-routing-key query)

2847

(setf-task-store-bgp-routing-key (concatenate 'string "bgp."

2848

                                                       (repository-id query))

2849

query))))

2850

2851

(defgeneric task-request-error-routing-key (task)

2852

(:method ((task task))

2853

(concatenate 'string (task-request-routing-key task) *error-routing-suffix*)))

2854

2855

(defgeneric task-request-reply-routing-key (task)

2856

(:method ((task task))

2857

(concatenate 'string (task-request-routing-key task) *reply-routing-suffix*)))

2858

2859

(defgeneric find-query-pattern (query id)

2860

(:documentation "Return the named bgp.")

2861

(:method ((query query) id)

2862

(find id (query-patterns query) :key #'agp-id :test #'string-equal)))

2863

2864

(defgeneric query-pattern-solutions (query id)

2865

(:documentation "return the latest value for a given bgp match.")

2866

(:method ((query query) id)

2867

(let ((agp (find id (query-patterns query) :key #'agp-id :test #'string-equal)))

2868

(cond (agp

2869

(agp-solutions agp))

2870

(t

2871

(log-warn "No AGP for id: ~s: ~s." query id)

2872

nil)))))

2873

2874

(defgeneric (setf query-pattern-solutions) (value query id)

2875

(:documentation "Set the latest value for a given bgp match.")

2876

(:method (field (query query) id)

2877

(let ((agp (find id (query-patterns query) :key #'agp-id :test #'string-equal)))

2878

(if agp

2879

(setf (agp-solutions agp) field)

2880

(log-warn "No AGP for id: ~s: ~s." query id))

2881

field)))

2882

2883

2884

(defgeneric query-runnable-p (query)

2885

(:documentation "Return true iff the queries variables have all been set to the result of an

2886

asynchronous store request.")

2887

2888

(:method ((query query))

2889

(every #'agp-completed-p (query-patterns query))))

2890

2891

(defmethod print-generator-tree ((query query) &rest args)

2892

(apply #'print-generator-tree (task-result-generator query) args))

2893

2894

#+(or)

2895

(progn ; part of bgp compilation

2896

(defgeneric compute-pattern-rewrite-operator (context rule-set)

2897

   (:documentation "Translate a rule set into an operator which, when applied to a statement pattern, produces

2898

another pattern which reflects the rules.")

2899

2900

(:method ((task data-task) rule-set)

2901

(compute-pattern-rewrite-operator (task-repository task) rule-set))

2902

2903

(:method ((task data-task) (rule-set null))

2904

#'identity)

2905

2906

(:method ((repository repository) (rule-sets cons))

2907

(let ((rewrite-operators (loop for set in rule-sets

2908

                                    collect (compute-pattern-rewrite-operator repository set))))

2909

(flet ((rewrite-pattern (pattern &optional (applied-operators nil))

2910

(or (loop for operator in rewrite-operators

2911

unless (find operator applied-operators)

2912

do (let ((antecedent-patterns (funcall operator pattern)))

2913

(when antecedent-patterns

2914

                                 (let ((operators (cons operator applied-operators)))

2915

(declare (dynamic-extent operators))

2916

(setf antecedent-patterns

2917

                                         (loop for pattern in antecedent-patterns

2918

                                               collect (rewrite-pattern pattern operators)))

2919

                                   (return `(bgp:quad-entail ,pattern ,@antecedent-patterns))))))

2920

pattern)))

2921

#'rewrite-pattern))))

2922

2923

2924

(defgeneric query-pattern-rewrite-operator (query)

2925

(:documentation

2926

"Return the operators which rewrites statement patterns according to the rules

2927

    in effect for the given query. If necessary, compile the operators - one each, from the rule sets

2928

specified for the query.")

2929

2930

(:method ((query query))

2931

(or (get-query-pattern-rewrite-operator query)

2932

(setf (query-pattern-rewrite-operator query)

2933

(compute-pattern-rewrite-operator query (query-pattern-rewrite-rule-sets query))))))

2934

)

2935

2936

(defgeneric initialize-task (task)

2937

(:method ((task task))

2938

(setf (task-start-time task) (task-time task)))

2939

(:method ((task data-task))

2940

(flet ((no-initialization-function (task)

2941

(log-warn "No initialization function present for task: ~a." task)))

2942

(call-next-method)

2943

;; cannot perform within a task environment, as it could change the task's revision

2944

;; in any case, should not happen as a rule as the revision binding occurs

2945

;; during instantiation

2946

;; (update-repository-revision-id (task-revision task))

2947

;; ensure that is it possible to get a transaction at this step.

2948

;; this ensures that access it autorized in order to avoid later failures

2949

(task-transaction task)

2950

(setf (task-result-generator task)

2951

(funcall (or (task-initialization-function task)

2952

#'no-initialization-function)

2953

task)))

2954

task)

2955

(:method ((query query))

2956

;; ensure the init function has been generated to construct the propagation graph

2957

(unless (task-initialization-function query)

2958

(compile-query query)

2959

(generate-accounting-note :abstract :task query))

2960

(call-next-method)))

2961

2962

2963

(defun check-query-status (&optional (query *query*))

2964

(when query

2965

(cond ((eq (task-state query) :terminate)

2966

(spocq.e:abort-error :query query :condition nil :expression "terminated"))

2967

((task-quota-exceeded-p query)

2968

(spocq.e:timeout-error :query query :condition nil :expression "timeout"))

2969

((task-active-p query)))))

2970

2971

(defgeneric terminate-task (task &optional condition)

2972

(:documentation "Internal task termination either as a side-effect of an error, to effect a

2973

time-out, or to carry out a request to terminate.

2974

TASK : task : the task instance to terminate

2975

CONDITION : condition : (optional) the condition which indicates termination.

2976

2977

In order to terminate a task,

2978

- mark the task's internal state

2979

- generate a final accounting note

2980

- terminate any parent

2981

- signal the condition in the task's thread. supply a default condition if needed

2982

leave any finalization to the task's principal thread")

2983

2984

(:method ((task null) &optional condition)

2985

(declare (ignore condition))

2986

nil)

2987

2988

(:method ((task task) &optional (condition

2989

                                    (spocq.e:request-error "task terminated: ~a" task)))

2990

(log-info "terminate-task: ~s~@[: ~a~]" (task-id task) condition)

2991

(generate-error-note (format nil "terminated: ~a~@[: ~a~]" (task-id task) condition) :task task)

2992

(setf (task-state task) :terminate)

2993

;; broadcast termination to all of the task's threads

2994

;; skip the current one as it is already handling some sort of exception

2995

(with-accounting

2996

(trace-threads terminate-task :task task)

2997

(generate-accounting-note :terminate :task task)

2998

;; iff a parent exists, terminate it as well

2999

(terminate-task (task-parent-task task))

3000

(let ((task-thread (task-thread task)))

3001

(if (and task-thread (bt:thread-alive-p task-thread))

3002

(flet ((delegate-signal ()

3003

(log-info "terminate-task: signaling: ~s: ~s -> ~s: ~s"

3004

                                (task-id task) (bt:current-thread) task-thread condition)

3005

(when condition (signal condition))))

3006

;; resignal or delegate condition

3007

(if (eq task-thread (bt:current-thread))

3008

(delegate-signal)

3009

(bt:interrupt-thread task-thread #'delegate-signal)))

3010

(log-warn (log-info "terminate-task: no thread: ~s" (task-id task)))))

3011

(log-info "terminate-task: returning"))))

3012

3013

3014

(defgeneric map-task-threads (function task)

3015

(:method ((function function) (task task))

3016

(declare (dynamic-extent function))

3017

(flet ((map-op (key value)

3018

(declare (ignore key))

3019

(funcall function value)))

3020

(declare (dynamic-extent #'map-op))

3021

(map-registry #'map-op (task-threads task)))))

3022

3023

(defgeneric add-task-thread (task thread)

3024

(:method ((task task) thread)

3025

(unless (task-active-p task)

3026

;; unless the thread is this one, it'a an error

3027

(cancel-thread thread)

3028

(error "failed to cancel thread for an inactive task: ~s ~s"

3029

task thread))

3030

(setf (get-registry (bt:thread-name thread) (task-threads task)) thread)

3031

task))

3032

3033

(defgeneric remove-task-thread (task thread)

3034

(:method ((task task) thread)

3035

(rem-registry (bt:thread-name thread) (task-threads task))

3036

task))

3037

3038

(defgeneric get-all-task-threads (task)

3039

(:method ((task task))

3040

(let ((threads ()))

3041

(flet ((collect (thread) (push thread threads)))

3042

(declare (dynamic-extent #'collect))

3043

(map-task-threads #'collect task))

3044

threads)))

3045

3046

(defgeneric task-thread-count (task)

3047

(:method ((task task))

3048

(registry-count (task-threads task))))

3049

3050

(defgeneric destroy-task-threads (task)

3051

(:method ((task task))

3052

(map-task-threads #'(lambda (thread)

3053

(ignore-errors (progn

3054

                                            (when (and (bt:thread-alive-p thread)

3055

                                                       (not (eq thread (bt:current-thread))))

3056

(bt:destroy-thread thread)

3057

(bt:join-thread thread)))))

3058

task)))

3059

3060

(defgeneric cancel-task-threads (task)

3061

(:documentation "cause all live tasks to cancel processing. join all non-active")

3062

(:method ((task task))

3063

(flet ((cancel-task-thread (thread)

3064

#+(or)(print (list :cancel thread

3065

(eq thread SB-THREAD::*INITIAL-THREAD*)

3066

(bt:thread-alive-p thread)))

3067

(multiple-value-bind (canceled-thread condition)

3068

;; eliminate a toplevel thread and any which can be killed

3069

(ignore-errors

3070

(cond ((eq thread SB-THREAD::*INITIAL-THREAD*)) ; just in case

3071

((bt:thread-alive-p thread)

3072

(cancel-thread thread :task task))

3073

(t

3074

(bt:join-thread thread))))

3075

(declare (ignore canceled-thread))

3076

(when condition

3077

(warn "cancel-task-thread failed: ~a ~a ~a" task thread condition))

3078

thread)))

3079

(declare (dynamic-extent #'cancel-task-thread))

3080

(map-task-threads #'cancel-task-thread task)

3081

task)))

3082

3083

3084

(defgeneric unschedule-task (task)

3085

(:method ((task task))

3086

(cancel-task-threads task)

3087

(typecase (task-operations task)

3088

(list (let* ((semaphore (task-thread-task-semaphore task))

3089

(hanging-thread-count (sb-thread::semaphore-waitcount semaphore)))

3090

(when (plusp hanging-thread-count)

3091

(sb-thread:signal-semaphore semaphore hanging-thread-count))))

3092

(sb-concurrency:mailbox

3093

(let* ((semaphore (sb-concurrency::mailbox-semaphore (task-operations task)))

3094

(hanging-thread-count (sb-thread::semaphore-waitcount semaphore)))

3095

(when (plusp hanging-thread-count)

3096

(sb-thread:signal-semaphore semaphore hanging-thread-count)))))

3097

task))

3098

3099

(defun cancel-thread (thread &rest args &key task)

3100

(flet ((cancel-if-found ()

3101

;;(print (cons :cancel-if-found (bt:current-thread)))

3102

(when (find-restart 'cancel-thread)

3103

(apply #'invoke-restart 'cancel-thread args)

3104

t)))

3105

(when task

3106

(remove-task-thread task thread))

3107

(if (eq thread (bt:current-thread))

3108

(cancel-if-found) ; should not return

3109

(when (bt:thread-alive-p thread)

3110

(bt:interrupt-thread thread #'cancel-if-found)

3111

t))))

3112

3113

3114

(defgeneric get-active-task (task &key wait timeout)

3115

(:method ((task task) &rest args)

3116

(declare (dynamic-extent args))

3117

(apply #'channel-get *algebra-task-channel* args)))

3118

3119

3120

3121

(defgeneric task-property (task property)

3122

(:method ((task null) (property t))

3123

nil)

3124

(:method ((task task) (property t))

3125

(getf (task-properties task) property)))

3126

3127

(defgeneric (setf task-property) (value task property)

3128

(:method (value (task null) (property t))

3129

value)

3130

(:method (value (task data-task) (property t))

3131

(setf (getf (task-properties task) property) value)))

3132

3133

3134

(defmethod (setf task-blank-node-skolemize) :before (value (task task))

3135

(assert (member *blank-node-skolemize* '(t :insert :export)) ()

3136

"blank-node-skolemize must be one of (t :insert :export)."))

3137

3138

(defun describe-properties ()

3139

(if *task*

3140

(task-property *task* :describe-properties)

3141

*describe-properties*))

3142

3143

(defun describe-property-p (predicate)

3144

(let ((properties (describe-properties)))

3145

(or (eq properties t)

3146

(typecase properties

3147

(null nil)

3148

(cons (member predicate properties :test #'eql))))))

3149

3150

(defgeneric task-uuid (task)

3151

(:method ((task task))

3152

(intern-uuid (task-id task))))

3153

3154

(defgeneric task-agent-id (task)

3155

(:method ((object t))

3156

nil)

3157

(:method ((task task))

3158

(let ((agent (task-agent task)))

3159

(when agent (agent-identifier agent)))))

3160

3161

(defgeneric task-agent-location (task)

3162

(:method ((object t))

3163

nil)

3164

(:method ((task task))

3165

(let ((agent (task-agent task)))

3166

(when agent (agent-location agent)))))

3167

3168

(defgeneric task-accounting-notes (task)

3169

(:method ((task task))

3170

;; copy the notes out of the task's statistics queue

3171

(let* ((statistics (task-statistics task))

3172

(notes (channel-get-all statistics)))

3173

(loop for note in notes do (channel-put statistics note))

3174

notes)))

3175

3176

(defmethod put-accounting-note ((task task) (note list))

3177

(trace-data put-accounting-note note)

3178

;; prepend task in case processing combines with those from another task

3179

(sb-concurrency:send-message (task-statistics task) (cons task note))

3180

note)

3181

3182

(defmethod task-request-location ((task null))

3183

nil)

3184

3185

(defmethod task-repository ((task null))

3186

*repository*)

3187

3188

;;;

3189

;;; transactions

3190

3191

(defun make-transaction (&rest args)

3192

(declare (dynamic-extent args))

3193

(apply #'make-instance *class.transaction* args))

3194

3195

(defmacro when-transaction-record ((record transaction &key error-p) &body body)

3196

`(let ((,record (transaction-record ,transaction)))

3197

(when ,record

3198

,@(when error-p

3199

`((assert-argument-type ,error-p ,record cffi:foreign-pointer)))

3200

(locally ,@body))))

3201

3202

(defmethod print-object ((object transaction) (stream t))

3203

(_print-unreadable-object (object stream :identity t :type t)

3204

(format stream "~a: ~a~@[.~a~].~:[RW~;RO~]"

3205

(bound-slot-value object 'id)

3206

(bound-slot-value object 'revision)

3207

(bound-slot-value object 'operation)

3208

(bound-slot-value object 'read-only))))

3209

3210

3211

(defmethod print-object ((object rdfcache-transaction) (stream t))

3212

(_print-unreadable-object (object stream :identity t :type t)

3213

(format stream "~a: @~a~@[.~a~].~:[RW~;RO~]"

3214

(bound-slot-value object 'id)

3215

;;(bound-slot-value object 'repository-id)

3216

(bound-slot-value object 'revision)

3217

(bound-slot-value object 'operation)

3218

(bound-slot-value object 'read-only))

3219

(let ((record (bound-slot-value object 'record)))

3220

(format stream " [~a @~a]"

3221

record (when record (rdfcache:transaction-status record))))))

3222

3223

(defgeneric transaction-repository (transaction)

3224

(:documentation "Return the transaction's respective repository.

3225

This is not directly bound, but rather retrieved from the revision

3226

upon which the transaction is based.")

3227

3228

(:method ((transaction transaction))

3229

(let ((revision (transaction-revision transaction)))

3230

(when revision

3231

(repository-revision-reference revision)))))

3232

3233

(defmethod repository-id ((transaction transaction))

3234

(let ((revision (transaction-revision transaction)))

3235

(when revision (repository-id revision))))

3236

3237

3238

(defgeneric clone-transaction (transaction &key api-key task-id)

3239

)

3240

3241

(defgeneric destroy-transaction (transaction)

3242

(:documentation "NB. This is intended to be called in exactly one of two contexts:

3243

- unregister-query: once the query is no longer active

3244

- the gc finalization operation

3245

as the first case uses the tasks lock and the second runs only in the garbage

3246

collector one no other thread has access to the task, no lock should be

3247

necessary here, but ...")

3248

(:method :around ((transaction transaction))

3249

(handler-bind ((error (lambda (condition)

3250

(log-warn "destroy-transaction: ~a" condition)

3251

(return-from destroy-transaction nil))))

3252

(bt:with-lock-held ((transaction-lock transaction))

3253

(call-next-method)))))

3254

3255

(defgeneric transaction-close (transaction disposition)

3256

(:documentation "ensure isolated access to transaction state and close it.

3257

This _does not_ destroy the transaction as it is calles from all operation threads.

3258

The transaction is destroyed in either finalize-query or in the few immediate

3259

repository operations which create a loca transaction")

3260

(:method :around ((transaction transaction) (disposition t))

3261

(cond (disposition ;; avoid recursive lock

3262

(bt:with-lock-held ((transaction-lock transaction))

3263

(call-next-method)))

3264

(t

3265

(call-next-method)))))

3266

3267

(defgeneric compute-transaction-uri (transaction)

3268

)

3269

3270

(defgeneric transaction-uri (transaction)

3271

(:method ((object null)) nil)

3272

(:method ((transaction transaction))

3273

(or (get-transaction-uri transaction)

3274

(setf-transaction-uri (compute-transaction-uri transaction) transaction))))

3275

3276

(defgeneric compute-revision-uri (transaction)

3277

)

3278

3279

(defgeneric revision-uri (transaction)

3280

(:documentation "return the uri which designates the revision autonomously as <urn:uuix:xxxx...>")

3281

(:method ((object null)) nil)

3282

(:method ((transaction transaction))

3283

(let ((revision (transaction-revision transaction)))

3284

(when revision

3285

(revision-uri revision))))

3286

(:method ((revision repository-revision))

3287

(or (get-repository-revision-revision-uri revision)

3288

(setf-repository-revision-revision-uri (compute-revision-uri revision) revision))))

3289

3290

(defgeneric repository-revision-uri (transaction)

3291

   (:documentation "return the uri which designates the revision respective the repository as <http://...?revixion=xxxx...>")

3292

(:method ((object null)) nil)

3293

(:method ((transaction transaction))

3294

(let ((revision (transaction-revision transaction)))

3295

(when revision

3296

(repository-revision-uri revision))))

3297

(:method ((revision repository-revision))

3298

(instance-identifier revision)))

3299

3300

(defgeneric repository-revision-record (revision)

3301

(:method ((object null)) nil)

3302

(:method ((transaction transaction))

3303

(let ((revision (transaction-revision transaction)))

3304

(when revision

3305

(repository-revision-record revision))))

3306

(:method ((revision repository-revision))

3307

(or (get-repository-revision-record revision)

3308

(let ((record (rlmdb:find-revision-record revision (repository-revision-id revision))))

3309

(cond (record

3310

(setf-repository-revision-record record revision))

3311

(t

3312

(log-warn "revision locates no record: ~s" revision)

3313

nil))))))

3314

3315

(defgeneric repository-revision-ordinal (revision)

3316

(:method ((object null)) nil)

3317

(:method ((revision repository-revision))

3318

(let ((record (repository-revision-record revision)))

3319

(when record

3320

(rlmdb:revision-record-ordinal record)))))

3321

3322

(defgeneric parent-revision-uri (transaction)

3323

(:method ((object null)) nil))

3324

3325

3326

(defun list-transaction-created-graph-ids (transaction)

3327

(loop for id being each hash-key of (transaction-created-graph-ids transaction)

3328

collect id))

3329

3330

(defun list-transaction-created-graphs (transaction)

3331

(loop for id being each hash-key of (transaction-created-graph-ids transaction)

3332

collect (repository-term-number-object transaction id)))

3333

3334

(defun list-transaction-deleted-graph-ids (transaction)

3335

(loop for id being each hash-key of (transaction-deleted-graph-ids transaction)

3336

collect id))

3337

3338

(defun list-transaction-deleted-graphs (transaction)

3339

(loop for id being each hash-key of (transaction-deleted-graph-ids transaction)

3340

collect (repository-term-number-object transaction id)))

3341

3342

(defun list-transaction-read-graph-ids (transaction)

3343

(loop for id being each hash-key of (transaction-read-graph-ids transaction)

3344

collect id))

3345

3346

(defun list-transaction-read-graphs (transaction)

3347

(loop for id being each hash-key of (transaction-read-graph-ids transaction)

3348

collect (repository-term-number-object transaction id)))

3349

3350

(defun list-transaction-modified-graph-ids (transaction)

3351

(loop for id being each hash-key of (transaction-modified-graph-ids transaction)

3352

collect id))

3353

3354

(defun list-transaction-modified-graphs (transaction)

3355

(loop for id being each hash-key of (transaction-modified-graph-ids transaction)

3356

collect (repository-term-number-object transaction id)))

3357

3358

3359

(defun (setf transaction-graph-id-created) (value transaction id)

3360

(if value

3361

(setf (gethash id (transaction-created-graph-ids transaction)) value)

3362

(remhash id (transaction-created-graph-ids transaction)))

3363

value)

3364

3365

(defun (setf transaction-graph-id-deleted) (value transaction id)

3366

(if value

3367

(setf (gethash id (transaction-deleted-graph-ids transaction)) value)

3368

(remhash id (transaction-deleted-graph-ids transaction)))

3369

value)

3370

3371

(defun (setf transaction-graph-id-modified) (value transaction id)

3372

(if value

3373

(setf (gethash id (transaction-modified-graph-ids transaction)) value)

3374

(remhash id (transaction-modified-graph-ids transaction)))

3375

value)

3376

3377

(defun (setf transaction-graph-id-read) (value transaction id)

3378

(if value

3379

(setf (gethash id (transaction-read-graph-ids transaction)) value)

3380

(remhash id (transaction-read-graph-ids transaction)))

3381

value)

3382

3383

3384

(defgeneric operation-read-only-p (operation)

3385

(:method ((expression cons))

3386

(operation-read-only-p (first expression)))

3387

#+(or)

3388

(:method ((operation symbol))

3389

(when (member operation '(ask construct describe order query

3390

select reduced distinct slice service)

3391

:test #'string-equal)

3392

t))

3393

(:method ((operation symbol))

3394

"recognize specific operations which modify - both sparql and gsp.

3395

others count as read"

3396

(if (member operation '(:update nil :post :put :delete) :test #'string-equal)

3397

nil t))

3398

(:method ((transaction transaction))

3399

(operation-read-only-p (transaction-operation transaction)))

3400

3401

(:method ((task task))

3402

(operation-read-only-p (task-operation task)))

3403

3404

(:method ((context null))

3405

nil))

3406

3407

;;;

3408

;;; query registry

3409

;;; !!! nb. the locks are in the composite register/unregister functions rather

3410

;;; !!! than the simple find operators

3411

3412

(defgeneric save-query (query)

3413

(:documentation "This is invoked as a side-effect of registering a query,

3414

which is a side-effect of initiate-task, which means any query invocation.")

3415

(:method ((query query))

3416

(let* ((signature (query-signature query))

3417

(expression (task-request-content query))

3418

(initial (subseq signature 0 2))

3419

(account-name (account-name (repository-account (task-repository query))))

3420

            (pathname (merge-pathnames (make-pathname :directory `(:relative "history" "queries" ,account-name ,initial)

3421

                                                      :name signature)

3422

*store-root-pathname*)))

3423

(unless (probe-file pathname)

3424

(ensure-directories-exist pathname)

3425

;; use :supersede as it is possible that two identical queries appear at the same time

3426

         (with-open-file (save-stream pathname :direction :output :if-does-not-exist :create :if-exists :supersede)

3427

(write-string expression save-stream)))

3428

pathname)))

3429

;; (test-sparql "select count(*) where {?s ?p ?o}" :repository-id "james/test")

3430

3431

(defun find-query (key)

3432

(get-registry (string key) *query-registry*))

3433

3434

(defun (setf find-query) (query key)

3435

(etypecase key

3436

(list (dolist (key key) (setf (find-query key) query)))

3437

(symbol (setf (find-query (symbol-name key)) query))

3438

(string

3439

(if query

3440

(setf (get-registry key *query-registry*) query)

3441

(rem-registry key *query-registry*))

3442

query)))

3443

3444

(defvar *last-query* )

3445

3446

(defgeneric register-query (query)

3447

(:method ((task task))

3448

(let ((start-time (or (task-start-time task)

3449

(setf (task-start-time task) (get-universal-time))))

3450

(id (task-id task)))

3451

(log-debug "task ~s. registered ~/format-iso-time/" id start-time)

3452

(when (boundp '*last-query*)

3453

(setq *last-query* task))

3454

(setf (find-query id) task)))

3455

(:method ((query query))

3456

(save-query query)

3457

(call-next-method)

3458

(dolist (agp (query-patterns query))

3459

(setf (find-query (agp-id agp)) query))))

3460

3461

(defgeneric close-task (task)

3462

(:documentation "actually clear any cached content in the task.

3463

report any accounting and errors, and unregister it")

3464

(:method ((task task))

3465

"for a task, ensure than any queues are cleared and notes are published"

3466

(handler-bind ((error (lambda (c)

3467

                             (log-error "close-task: condition signaled for task ~a: ~a" (task-id task) c)

3468

(print-stacktrace *trace-output*)

3469

(return-from close-task (values task c)))))

3470

(bt:with-lock-held ((task-lock task))

3471

;; guard for simultaneous termination from multiple sources

3472

(when (eq task (find-query (task-id task)))

3473

(unregister-task task)

3474

;; allow any still active treads to complete

3475

(channel-get-all (task-transactions task))

3476

(channel-get-all (task-operations task))

3477

;; before killing any which remain

3478

(cancel-task-threads task)

3479

;; publish the notes specific to the class only

3480

(publish-accounting-notes task (task-accounting-destination task))

3481

(print-error-conditions task (task-error-destination task))

3482

;; after that, ensure that the task's transaction is closed

3483

(let ((transaction (get-task-transaction task)))

3484

(when transaction

3485

(destroy-transaction transaction)

3486

#+(or)

3487

(cond ((transaction-open-p transaction)

3488

(transaction-close transaction nil))

3489

((transaction-record transaction)

3490

(destroy-transaction transaction)))

3491

#+(or)

3492

;; do not clear the transaction as it figures in post-processing

3493

;; the record is destroyed when it closes w/ commit or abort

3494

(setf-task-transaction nil task)))

3495

(log-notice "task closed: ~a" (task-id task))

3496

(setf (task-state task) :finalized)))

3497

task))

3498

(:method ((task data-task))

3499

#+(or)

3500

(let ((ephemeral-terms (task-ephemeral-terms task)))

3501

(when ephemeral-terms

3502

(rdfcache::destroy-ephemeral-terms ephemeral-terms))

3503

(setf-task-ephemeral-terms nil task))

3504

(clear-registry (task-lexical->spocq-term-registry task))

3505

(clear-registry (task-spocq->store-term-registry task))

3506

(call-next-method)))

3507

3508

(defgeneric unregister-task (task)

3509

(:documentation "Remove the query from the global register by-id")

3510

(:method ((task task))

3511

(log-debug "task ~s. unregistered [~/format-iso-time/ - ~/format-iso-time/) = ~d/~d seconds."

3512

(task-id task) (task-start-time task) (task-time task)

3513

(float (/ (- (get-internal-run-time) (task-start-run-time task))

3514

internal-time-units-per-second))

3515

(float (/ (- (get-internal-real-time) (task-start-real-time task))

3516

internal-time-units-per-second)))

3517

(setf (find-query (task-id task)) nil))

3518

3519

(:method ((query query))

3520

(dolist (agp (query-patterns query))

3521

(setf (agp-predecessors agp) nil

3522

(agp-successors agp) nil

3523

(agp-pattern-functions agp) nil)

3524

(setf (find-query (agp-id agp)) nil))

3525

(call-next-method)))

3526

3527

(defparameter *close-task-in-thread* nil)

3528

3529

(defgeneric finalize-task (task)

3530

(:documentation "clear or arrange to clear any cached content in the task

3531

by delegating to close-task

3532

report any accounting and errors, and unregister it")

3533

(:method ((task data-task))

3534

;; (clrhash (task-store->spocq-term-registry task))

3535

;; can destroy the ephemeral terms, but the transaction needs to remain

3536

;; intact until a possible with-transaction forms complete

3537

;; first, clear out any threads

3538

(call-next-method))

3539

3540

(:method ((task task))

3541

"arrange to unregister and clear task"

3542

(if *close-task-in-thread*

3543

(bt:make-thread #'(lambda () (close-task task)))

3544

(close-task task))

3545

task))

3546

3547

3548

(defun query-count ()

3549

(registry-count *query-registry*))

3550

3551

(defun map-queries (function &optional (registry *query-registry*))

3552

(declare (dynamic-extent function))

3553

(flet ((apply-to-query (key object)

3554

(when (and (typep object 'query) (equal key (task-id object)))

3555

(funcall function object))))

3556

(declare (dynamic-extent #'apply-to-query))

3557

(map-registry #'apply-to-query registry)))

3558

3559

(defun list-queries (&optional (registry *query-registry*))

3560

(collect-list (collect-query)

3561

(map-queries #'collect-query registry)))

3562

3563

(defun list-query-properties (&optional (registry *query-registry*))

3564

(let ((now (get-universal-time)))

3565

(collect-list (collect-properties)

3566

(flet ((query-properties (q)

3567

(let ((start (task-start-time q)))

3568

(collect-properties (list (cons (task-id q) (task-user-id q))

3569

                                            (list :start start :elapsed (- now start) :limit (task-time-limit q))

3570

(task-state q)

3571

                                            (mapcar #'agp-id (query-patterns q)))))))

3572

(declare (dynamic-extent #'query-properties))

3573

(map-queries #'query-properties registry)))))

3574

3575

3576

(defun find-query-prototype (repository signature bindings)

3577

(let ((key (list repository signature bindings)))

3578

(declare (dynamic-extent key))

3579

(get-registry key *query-prototypes*)))

3580

3581

(defgeneric (setf find-query-prototype) (query repository signature bindings)

3582

(:method ((query t) (repository repository) (signature t) (bindings t))

3583

(setf (find-query-prototype (repository-id repository) signature bindings) query))

3584

3585

(:method ((query query) (repository-id string) signature bindings)

3586

(setf (get-registry (list repository-id signature bindings) *query-prototypes*)

3587

query))

3588

(:method ((query null) (repository-id string) signature bindings)

3589

(rem-registry (list repository-id signature bindings) *query-prototypes*))

3590

3591

(:method ((query null) (repository-id (eql t)) (signature (eql t)) (bindings (eql t)))

3592

(clrhash *query-prototypes*))

3593

3594

(:method ((query null) (repository-id string) (signature (eql t)) (bindings (eql t)))

3595

(let ((registry *query-prototypes*))

3596

(flet ((clear-repository-prototypes (key value)

3597

(declare (ignore value))

3598

(when (equal (first key) repository-id)

3599

(rem-registry key registry))))

3600

(declare (dynamic-extent #'clear-repository-prototypes))

3601

(maphash #'clear-repository-prototypes registry)))))

3602

3603

3604

(defgeneric query-variable-information (query variable)

3605

(:method ((query null) (variable t))

3606

())

3607

(:method ((query query) (variable t))

3608

(getf (query-variables query) variable)))

3609

3610

(defgeneric (setf query-variable-information) (information query variable)

3611

(:method ((information t) (query null) (variable t))

3612

information)

3613

(:method ((information t) (query query) (variable symbol))

3614

(setf (getf (query-variables query) variable) information)))

3615

3616

(defun query-variable-opacity (query variable)

3617

(getf (query-variable-information query variable) :opacity))

3618

3619

(defun (setf query-variable-opacity) (value query variable)

3620

(etypecase variable

3621

(cons

3622

(dolist (variable variable value)

3623

(setf (getf (query-variable-information query variable) :opacity) value)))

3624

(symbol

3625

(setf (getf (query-variable-information query variable) :opacity) value))))

3626

3627

(defun (setf variable-opacity) (value variable)

3628

(setf (query-variable-opacity *query* variable) value))

3629

3630

(defun list-thread-tasks ()

3631

(let ((thread-tasks ())

3632

(thread-to-interrupt nil))

3633

(dolist (thread (bt:all-threads))

3634

(setf thread-to-interrupt thread)

3635

(bt:interrupt-thread thread #'(lambda ()

3636

                                       (push (list (bt:current-thread) *task*) thread-tasks)

3637

(setf thread-to-interrupt nil)))

3638

(loop (unless thread-to-interrupt (return))))

3639

thread-tasks))

3640

3641

(defgeneric query-values-argument (query dimensions)

3642

   (:documentation "Return any values argument which was provided with the query request which agrees, by dimension")

3643

(:method ((query query) (dimensions list))

3644

(rest (assoc dimensions (task-property query :request-values) :test #'equal)))

3645

(:method ((query t) (dimensions t))

3646

nil))

3647

3648

3649

;;;

3650

;;; view

3651

3652

(defmethod initialize-instance ((instance view) &rest args &key repository-id

3653

(repository (repository repository-id)))

3654

(apply #'call-next-method instance

3655

:repository (static-repository repository) ;; coerce to the base instance

3656

args))

3657

3658

(defmethod initialize-clone ((old view) (new view) &rest initargs &key

3659

(name (_slot-value old 'name))

3660

(query (_slot-value old 'query))

3661

(dimensions (_slot-value old 'dimensions))

3662

(repository (_slot-value old 'repository)))

3663

"a cloned instance w/metadata gets cloned metadata extended with additions."

3664

(declare (dynamic-extent initargs))

3665

(log-debug "initialize-clone: view")

3666

(apply #'call-next-method old new

3667

:name name

3668

:query query

3669

:dimensions dimensions

3670

:repository repository

3671

initargs))

3672

3673

(defmethod print-object ((object view) (stream t) &aux (*print-pretty* nil))

3674

(_print-unreadable-object (object stream :identity t :type t)

3675

(format stream "~a" (_slot-value object 'identifier))))

3676

3677

(defun make-view (&rest args)

3678

(apply #'make-instance 'view args))

3679

3680

(defparameter *view-designator-scanner*

3681

(cl-ppcre:create-scanner "$[^/]+/[^/]+$/$.+$"))

3682

3683

(defgeneric view (data)

3684

(:method ((instance view))

3685

instance)

3686

(:method ((designator string))

3687

(multiple-value-bind (success components)

3688

(cl-ppcre:scan-to-strings *view-designator-scanner* designator)

3689

(if success

3690

(or (repository-view-definition (aref components 0) (aref components 1))

3691

(spocq.e:view-not-found-error :identifier designator))

3692

           (spocq.e:argument-type-error :datum designator :operator 'view :expected-type 'view-designator)))))

3693

3694

(defun view-designator-p (designator)

3695

(when (cl-ppcre:scan-to-strings *view-designator-scanner* designator)

3696

t))

3697

3698

(deftype view-designator () '(satisfies view-designator-p))

3699

3700

3701

(defgeneric view-identifier (view)

3702

(:method ((view view))

3703

(instance-identifier view)))

3704

3705

(defgeneric compute-view-identifier (account repository view)

3706

(:documentation "Return the respective repository identifier extended with the view name.

3707

This intends to be generic across hosts, rather than using the host-specific resource uri.")

3708

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

3709

     (intern-iri (concatenate 'string "http" "://" (site-name) "/accounts/" account-name "/repositories/" repository-name "/views/" view-name)))

3710

(:method ((account account) (repository t) (view t))

3711

(compute-view-identifier (account-name account) repository view))

3712

(:method ((account t) (repository repository) (view t))

3713

(compute-view-identifier account (repository-name repository) view))

3714

(:method ((account t) (repository t) (view view))

3715

(compute-view-identifier account repository (view-name view))))

3716

3717

(defgeneric compute-view-uri (account repository view)

3718

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

3719

     (intern-iri (concatenate 'string *site-protocol* "://" (host-name) "/" account-name "/" repository-name "/" view-name)))

3720

(:method ((account account) (repository t) (view t))

3721

(compute-view-uri (account-name account) repository view))

3722

(:method ((account t) (repository repository) (view t))

3723

(compute-view-uri account (repository-name repository) view))

3724

(:method ((account t) (repository t) (view view))

3725

(compute-view-uri account repository (view-name view))))

3726

3727

(defgeneric compute-view-admin-uri (account repository view)

3728

(:documentation "Return the respective repository identifier extended with the view name.

3729

This intends to be generic across hosts, rather than using the host-specific resource uri.")

3730

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

3731

     (intern-iri (concatenate 'string *site-protocol* "://" (host-name) "/accounts/" account-name "/repositories/" repository-name "/views/" view-name)))

3732

(:method ((account account) (repository t) (view t))

3733

(compute-view-admin-uri (account-name account) repository view))

3734

(:method ((account t) (repository repository) (view t))

3735

(compute-view-admin-uri account (repository-name repository) view))

3736

(:method ((account t) (repository t) (view view))

3737

(compute-view-admin-uri account repository (view-name view))))

3738

3739

(defmethod compute-instance-identifier ((resource view))

3740

(compute-view-identifier (repository-account (view-repository resource))

3741

(view-repository resource)

3742

(view-name resource)))

3743

3744

(defgeneric view-admin-uri (view)

3745

(:method ((view view))

3746

(compute-view-admin-uri (repository-account (view-repository view))

3747

(view-repository view)

3748

(view-name view))))

3749

3750

(defgeneric view-account (view)

3751

(:method ((view view))

3752

(repository-account (view-repository view))))

3753

3754

(defgeneric view-dimensions (view)

3755

(:method ((view view))

3756

(or (get-view-dimensions view)

3757

(setf (view-dimensions view) (compute-view-dimensions view)))))

3758

3759

(defgeneric compute-view-dimensions (view)

3760

(:documentation "Returns the _unsorted_ projected variables.

3761

for a select, this will reflect the projection order.

3762

For a construct, this will need to be sorted.")

3763

(:method ((view view))

3764

(sort (copy-list (expression-projected-variables (view-sse-expression view)))

3765

#'string-lessp)))

3766

3767

(defgeneric view-query (view)

3768

(:method ((view view))

3769

(cond ((get-view-query view))

3770

(t

3771

(read-view-definition view)

3772

(get-view-query view)))))

3773

3774

3775

3776

(defgeneric qualified-view-name (view)

3777

(:method ((view view))

3778

(concatenate 'string

3779

(account-name (view-account view)) "_"

3780

(repository-name (view-repository view)) "_"

3781

(view-name view))))

3782

3783

(defgeneric view-sse-expression (view)

3784

(:method ((view view))

3785

(or (get-view-sse-expression view)

3786

(handler-case (multiple-value-bind (sse-expression options)

3787

                                            (parse-sparql (view-query view))

3788

(setf (view-options view) options)

3789

(setf (view-sse-expression view) sse-expression))

3790

(error (c)

3791

(log-warn "view-sse-expression: parse-sparql error: ~a: ~a"

3792

(view-name view) c)

3793

(setf (view-options view) nil)

3794

(setf (view-sse-expression view) '(spocq.a:|table| spocq.a:|unit|)))))))

3795

3796

3797

(defgeneric view-options (view)

3798

(:method ((view view))

3799

(or (get-view-options view)

3800

(handler-case (multiple-value-bind (sse-expression options)

3801

                                            (parse-sparql (view-query view))

3802

(setf (view-sse-expression view) sse-expression)

3803

(setf (view-options view) options))

3804

(error (c)

3805

(log-warn "view-sse-expression: parse-sparql error: ~a: ~a"

3806

(view-name view) c)

3807

(setf (view-sse-expression view) '(spocq.a:|table| spocq.a:|unit|))

3808

             (setf (view-options view) (make-TASK-INDICES :BLANK-NODE-INDEX 0 :SEQUENCE-INDEX 0 :VARIABLE-INDEX 0)))))))

3809

3810

(defgeneric view-operation (view)

3811

(:method ((view view))

3812

(first (view-sse-expression view))))

3813

3814

(defgeneric view-service-references (view)

3815

(:documentation "extract service locations from the query text.

3816

    examine constant locations to collect external sources, and internal repositories, but not sub-query views.")

3817

(:method ((view view))

3818

(or (get-view-service-references view)

3819

(loop for service-form in (expression-service-forms (view-sse-expression view))

3820

with services = ()

3821

for location = (second service-form)

3822

do (multiple-value-bind (protocol authority repository-id view-name)

3823

                                   (parse-url-authority+path location :junk-allowed t)

3824

(when protocol

3825

(if (is-local-host authority)

3826

(let ((repository (repository repository-id :if-does-not-exist nil)))

3827

(when repository

3828

(unless view-name

3829

(push repository services))))

3830

                      (let ((service-repository (service-repository location :if-does-not-exist nil)))

3831

(when service-repository

3832

(push service-repository services))))))

3833

finally (return services)))))

3834

3835

(defgeneric view-view-references (view)

3836

(:documentation "extract service locations from the query text.

3837

examine constant locations to collect sub-query views.")

3838

(:method ((view view))

3839

(or (get-view-view-references view)

3840

(loop for service-form in (expression-service-forms (view-sse-expression view))

3841

with views = ()

3842

for location = (second service-form)

3843

do (multiple-value-bind (protocol authority repository-id view-name)

3844

                                   (parse-url-authority+path location :junk-allowed t)

3845

(when protocol

3846

(when (is-local-host authority)

3847

(let ((repository (repository repository-id :if-does-not-exist nil)))

3848

(when (and repository view-name)

3849

(let ((view (repository-view-definition repository view-name)))

3850

(when view (push view views))))))))

3851

finally (return views)))))

3852

3853

3854

;;;

3855

;;; linked-resource

3856

3857

(defmethod initialize-instance ((instance linked-resource) &key)

3858

(call-next-method)

3859

(unless (slot-boundp instance 'uri)

3860

(setf-resource-uri (compute-resource-uri instance) instance)))

3861

3862

(defgeneric compute-resource-uri (linked-resource)

3863

(:documentation "Returns the url to be used to locate the resource for http access.")

3864

(:method ((account account))

3865

(compute-account-uri account))

3866

(:method ((repository repository))

3867

(compute-repository-uri (repository-account repository) repository))

3868

(:method ((resource repository-revision))

3869

(compute-repository-revision-uri resource))

3870

(:method ((resource view))

3871

(compute-view-uri (repository-account (view-repository resource)) (view-repository resource) resource)))

3872

3873

3874

(defparameter *resource-uri-scanner*

3875

(cl-ppcre:create-scanner '(:sequence

3876

:start-anchor

3877

(:alternation "https" "http")

3878

"://"

3879

(:greedy-repetition 1 nil (:inverted-char-class #\/))

3880

"/"

3881

(:register (:greedy-repetition 1 nil :everything)))))

3882

3883

(defgeneric resource-site-uri (linked-resource)

3884

(:method ((resource linked-resource))

3885

(or (get-resource-site-uri resource)

3886

(let ((uri (resource-uri resource)))

3887

(multiple-value-bind (success components)

3888

                                (cl-ppcre:scan-to-strings *resource-uri-scanner* (spocq:url-lexical-form uri))

3889

(unless success

3890

(error "resource-site-uri: invalid resource uri: ~s" uri))

3891

             (setf-resource-site-uri (intern-iri (format nil "http://~a/~a" (site-name) (aref components 0)))

3892

resource))))))

3893

3894

;;;

3895

;;; account

3896

3897

(defmethod initialize-instance ((instance account) &rest initargs &key name (user (user name)))

3898

(declare (dynamic-extent initargs))

3899

(apply #'call-next-method instance

3900

:title name

3901

:owner-id (instance-identifier user)

3902

:user user

3903

initargs))

3904

3905

(defgeneric account (object &rest args)

3906

(:method ((account account) &key)

3907

account)

3908

(:method ((name string) &rest args)

3909

;;coerce the name to one without "." - a historic constraint

3910

(setf name (substitute #\- #\. name))

3911

;; locate the named account or create a new one.

3912

(or (get-registry name *accounts*)

3913

(setf (get-registry name *accounts*)

3914

(apply #'make-instance *class.account* :name name args)))))

3915

3916

(defmethod print-object ((object account) (stream t) &aux (*print-pretty* nil))

3917

(_print-unreadable-object (object stream :identity t :type t)

3918

(format stream "~a"

3919

(bound-slot-value object 'name))))

3920

3921

3922

(defgeneric create-account (name &key if-exists email)

3923

(:documentation "iff the account does not yet exist, create it.")

3924

3925

(:method ((id string) &rest args)

3926

(declare (dynamic-extent args))

3927

(apply #'create-account (account id) args)))

3928

3929

(defgeneric compute-account-identifier (account)

3930

(:documentation "Yields the generic identifier for an account across all hosts

3931

within a site. This serves as the for authorization identifier")

3932

(:method ((account-name string))

3933

(intern-iri (concatenate 'string "http" "://" (site-name) "/accounts/" account-name)))

3934

(:method ((account account))

3935

(compute-account-identifier (account-name account))))

3936

3937

(defgeneric compute-account-uri (account)

3938

(:documentation "Yields the host-specific identifier to operate on the account contents

3939

through the http api")

3940

(:method ((account-name string))

3941

(intern-iri (concatenate 'string *site-protocol* "://" (host-name) "/" account-name)))

3942

(:method ((account account))

3943

(compute-account-uri (account-name account))))

3944

3945

(defgeneric compute-account-admin-uri (account)

3946

(:documentation "Yields the host-specific identifier to operate on the account metadata

3947

through the http api")

3948

(:method ((account-name string))

3949

(intern-iri (concatenate 'string *site-protocol* "://" (host-name) "/system/accounts/" account-name)))

3950

(:method ((account account))

3951

(compute-account-admin-uri (account-name account))))

3952

3953

(defmethod compute-instance-identifier ((account account))

3954

(compute-account-identifier account))

3955

3956

(defgeneric account-admin-uri (account)

3957

(:method ((account account))

3958

(compute-account-admin-uri account)))

3959

3960

(defgeneric account-uri (transaction)

3961

(:method ((context null)) nil)

3962

(:method ((account account))

3963

(resource-uri account))

3964

(:method ((account-name string))

3965

(compute-account-uri account-name))

3966

(:method ((repository repository))

3967

(account-uri (repository-account repository))))

3968

3969

(defgeneric account-identifier (transaction)

3970

(:method ((context null)) nil)

3971

3972

(:method ((account-name string))

3973

(compute-account-identifier account-name))

3974

3975

(:method ((account account))

3976

(instance-identifier account))

3977

3978

(:method ((repository repository))

3979

(account-identifier (repository-account repository))))

3980

3981

(defmethod resource-pathname-element ((account spocq.i:account))

3982

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

3983

3984

(defgeneric account-uuid (repository)

3985

(:documentation "This is value constitutes the permanent identifier for an account,

3986

independent of any change to its name. For rdfcache-related account, it is captured

3987

in the service catalog. For others it is generated from the context.")

3988

(:method ((account-name string))

3989

(account-uuid (account account-name))))

3990

3991

(defgeneric account-equal-p (account1 account2)

3992

   (:documentation "establich equality of accounts and account-related things as either the identical objects or devolving

3993

to the account / repository name and testing just the respective account component.")

3994

(:method ((id1 string) (id2 string))

3995

     ;; test for identity through to the first '/' to permit elementary account names and repository identifiers

3996

(loop for char1 across id1

3997

for char2 across id2

3998

when (and (eql char2 #\/) (eql char2 #\/))

3999

do (return t)

4000

unless (eql char1 char2)

4001

do (return nil)

4002

finally (return t)))

4003

(:method ((account account) (id t))

4004

(account-equal-p (account-name account) id))

4005

(:method ((id t) (account account))

4006

(account-equal-p id (account-name account)))

4007

(:method ((repository repository) (id t))

4008

(account-equal-p (repository-id repository) id))

4009

(:method ((id t) (repository repository))

4010

(account-equal-p id (repository-id repository))))

4011

4012

(defgeneric control-account-access (account)

4013

(:method ((account account)) t))

4014

4015

(defgeneric control-repository-access (account)

4016

(:method ((account account)) t))

4017

4018

(defgeneric control-view-access (account)

4019

(:method ((account account)) nil))

4020

4021

4022

;;;

4023

;;; agent

4024

4025

(defmethod initialize-instance ((instance agent) &key name admin-p session)

4026

(declare (ignore admin-p session))

4027

(call-next-method)

4028

(when name

4029

(let ((capabilities (agent-capabilities instance))

4030

(system-repository-nametring (iri-lexical-form (compute-repository-identifier name "system")))

4031

(modes '(|acl|:|Read| |acl|:|Write|)))

4032

(loop for mode in modes

4033

for capability = (cons system-repository-nametring mode)

4034

do (setf (get-registry capability capabilities) t)))))

4035

4036

4037

(defun make-agent (&rest initargs &key (name nil) (location nil) (admin-p nil) &allow-other-keys)

4038

(apply #'make-instance

4039

(cond (admin-p 'administrator)

4040

(name *class.authenticated-agent*)

4041

(location *class.located-agent*)

4042

(t *class.agent*))

4043

initargs))

4044

4045

 (defun ensure-agent (&rest initargs &key (name nil) (identifier nil) (location nil) token password session

4046

&allow-other-keys)

4047

"Depending on agent initargs, look first for the respective extand agent.

4048

If not found, instantiate one and cache it."

4049

(let ((agent (or (when session (gethash (list :session session) *users*))

4050

(when token (gethash (list :token token) *users*))

4051

(when password (gethash (list :password name password) *users*))

4052

;; allow anonymous zser

4053

(gethash (list :name name) *users*)

4054

;; either known or make a new one

4055

(apply #'make-agent initargs))))

4056

(setf (gethash (list :name name) *users*) agent)

4057

(setf (gethash name *users*) agent)

4058

(when location (setf (gethash (list :location location) *users*) agent))

4059

(when token (setf (gethash (list :token token) *users*) agent))

4060

(when password (setf (gethash (list :password name password) *users*) agent))

4061

(when identifier (gethash identifier *users*) agent)

4062

(when session (setf (gethash (list :session session) *users*) agent))

4063

agent))

4064

4065

4066

(defmethod initialize-instance ((instance authenticated-agent) &rest initargs &key (account nil))

4067

(declare (dynamic-extent initargs))

4068

(etypecase account

4069

(null )

4070

(string (setf account (account account)))

4071

(account ))

4072

(apply #'call-next-method instance

4073

:account account

4074

initargs))

4075

4076

(defgeneric agent-identifier (agent)

4077

(:method ((agent agent))

4078

(instance-identifier agent)))

4079

4080

(defgeneric agent-equal-p (agent1 agent2)

4081

(:documentation "establish agent equality as either the identical objects or

4082

the same name or identifier.")

4083

(:method ((name1 string) (name2 string))

4084

(equalp name1 name2))

4085

(:method :around ((agent1 agent) (agent2 agent))

4086

(or (eq agent1 agent2)

4087

(call-next-method)))

4088

(:method ((user1 user) (user2 user))

4089

(equalp (user-name user1) (user-name user2)))

4090

(:method ((agent1 agent) (agent2 agent))

4091

(iri-equal (agent-identifier agent1) (agent-identifier agent2)))

4092

(:method ((name string) (agent user))

4093

(equalp name (user-name agent)))

4094

(:method ((agent user) (name string))

4095

(equalp name (user-name agent)))

4096

(:method ((id spocq:iri) (agent agent))

4097

(iri-equal id (agent-identifier agent)))

4098

(:method ((agent agent) (id spocq:iri))

4099

(iri-equal id (agent-identifier agent)))

4100

(:method ((id1 spocq:iri) (id2 spocq:iri))

4101

(iri-equal id1 id2))

4102

(:method ((id1 account) (id2 t))

4103

(iri-equal (resource-uri id1) id2))

4104

(:method ((id1 t) (id2 account))

4105

(iri-equal id1 (resource-uri id2)))

4106

4107

(:method ((object1 t) (object2 t))

4108

nil))

4109

4110

(defgeneric (setf agent-capability) (value agent capability)

4111

(:method (determination (agent agent) (capability t))

4112

(setf (get-registry capability (agent-capabilities agent)) determination))

4113

(:method ((determination null) (agent agent) (capability (eql t)))

4114

(clear-registry (agent-capabilities agent))

4115

t))

4116

4117

(defgeneric agent-capability (agent capability)

4118

(:method ((agent agent) (capability t))

4119

(get-registry capability (agent-capabilities agent))))

4120

4121

;;;

4122

;;; authorization-list

4123

4124

4125

(defmethod initialize-instance ((instance authorization-list) &rest initargs

4126

                                 &key resource (identifier (instance-identifier resource)))

4127

(declare (dynamic-extent initargs))

4128

(apply #'call-next-method instance

4129

:identifier identifier

4130

initargs))

4131

4132

(defmethod compute-resource-store-repository-id ((instance authorization-list))

4133

(compute-resource-store-repository-id (authorization-list-resource instance)))

4134

4135

(defmethod instance-repository-id ((instance authorization-list))

4136

(instance-repository-id (authorization-list-resource instance)))

4137

4138

4139

4140

#+(or)

4141

(defmethod initialize-instance :after ((instance authorization-list) &rest args)

4142

(print (list :al instance (resource-state instance) args)))

4143

4144

#+(or)

4145

(defmethod initialize-instance :after ((instance object-with-persistent-metadata) &rest args)

4146

(print (list :owpm instance (resource-state instance) args)))

4147

4148

4149

(defmethod initialize-instance ((instance location-authorization) &key locations)

4150

(labels ((location-predicate (location)

4151

(cond ((find #\, location :test #'char=)

4152

(loop for location in (split-string location #(#\,))

4153

collect (location-predicate location)))

4154

((every #'(lambda (c) (or (digit-char-p c) (eql c #\.))) location)

4155

(let ((authorized-location location))

4156

(flet ((test-location-string (given-location)

4157

(string-equal authorized-location given-location)))

4158

#'test-location-string)))

4159

(t

4160

(let ((authorized-location-canner

4161

(cl-ppcre:create-scanner location)))

4162

(flet ((test-location-pattern (given-location)

4163

(cl-ppcre:scan authorized-location-canner

4164

given-location)))

4165

#'test-location-pattern))))))

4166

(setf-authorization-location-predicates (loop for location in locations

4167

                                                   for predicate = (location-predicate location)

4168

                                                   if (listp predicate)

4169

append predicate

4170

                                                   else collect predicate)

4171

instance)

4172

(call-next-method)))

4173

4174

4175

(defmethod compute-class-persistent-slots ((class authorization-class))

4176

"The codec logic for an authorization does not depend on its own slots, rather it collects

4177

the properties for its access controls, therefore the persinent slots are those for the

4178

class authorization and its concrete sub-classes"

4179

4180

(let ((collected-slots ()))

4181

(labels ((walk-classes (class)

4182

(c2mop:ensure-finalized class)

4183

(loop for sd in (class-persistent-slots class)

4184

do (pushnew sd collected-slots :key #'c2mop:slot-definition-name))

4185

(loop for sub-class in (c2mop:class-direct-subclasses class)

4186

do (walk-classes sub-class))))

4187

(walk-classes (find-class 'authorization)))

4188

collected-slots))

4189

4190

(defmethod print-object ((object authorization-list) (stream t))

4191

(_print-unreadable-object (object stream :type t :identity t)

4192

(format stream "~a" (bound-slot-value object 'identifier))))

4193

4194

(defmethod print-object ((object authorization) (stream t))

4195

(_print-unreadable-object (object stream :type t :identity t)

4196

(print-authorization-slots object stream)))

4197

4198

(defgeneric print-authorization-slots (authorization stream)

4199

(:method :around ((authorization t) (stream t))

4200

(let ((*print-pretty* nil)) (call-next-method)))

4201

(:method ((authorization authorization) (stream t))

4202

(format stream "~:[?~;~:*~a~]~@[ to ~a~]~@[ not to ~a~]~@[ for ~a ~]"

4203

(authorization-access-mode authorization)

4204

(authorization-access-to authorization)

4205

(authorization-no-access-to authorization)

4206

(authorization-agent-class authorization)))

4207

(:method ((authorization location-authorization) (stream t))

4208

(call-next-method)

4209

(format stream "~@[from ~a ~]" (authorization-locations authorization)))

4210

(:method ((authorization authenticated-authorization) (stream t))

4211

(call-next-method)

4212

(format stream "~@[(~a) ~]" (authorization-agent-id authorization))))

4213

4214

4215

;;;

4216

;;; authorized-resource

4217

4218

(defmethod compute-instance-identifier ((revision repository-revision))

4219

"Delegate to the revision uri method"

4220

(compute-repository-revision-uri revision))

4221

4222

(defmethod compute-instance-identifier ((resource user))

4223

(compute-user-identifier resource))

4224

4225

4226

4227

4228

(defgeneric compute-user-identifier (account)

4229

(:method ((user-name string))

4230

(intern-iri (format nil "http://~a/users/~a" (site-name) user-name)))

4231

(:method ((user user))

4232

(compute-user-identifier (user-name user))))

4233

4234

4235

;;;

4236

;;; profile

4237

4238

(defmethod (setf profile-homepage) ((homepage string) (resource profile-resource))

4239

(if (url-string-p homepage)

4240

(setf (profile-homepage resource) (spocq.i::intern-iri homepage))

4241

(error 'type-error :expected-type 'url-string :datum homepage)))

4242

4243

;;;

4244

;;; repository

4245

4246

#+(or) ; suberseded 20160602

4247

(defmethod initialize-instance ((instance repository) &rest initargs &key

4248

id account)

4249

"If no lock has been supplied, create one. This allows delegates to share with their reference.

4250

If no account is provided, determine it based on the repository's external name"

4251

(declare (dynamic-extent initargs))

4252

(with-slots (lock) instance

4253

(unless (slot-boundp instance 'lock)

4254

(setf lock (bt:make-lock id)))

4255

;;;!!! this needs to distinguish local repositories from service locations

4256

;;;!!! better yet, the class hierarchy should change to make local v/s service repositories

4257

(destructuring-bind (account-name repository-name &rest rest)

4258

(parse-repository-id id)

4259

(declare (ignore rest)) ; allow for variants for service locations

4260

(unless account

4261

(setf account (account account-name)))

4262

(apply #'call-next-method instance

4263

:account account

4264

:name repository-name

4265

:title repository-name

4266

initargs))))

4267

4268

(defmethod initialize-instance ((instance repository) &rest initargs &key

4269

class id account name

4270

                                 (authorization-list (find-repository-authorization-list id)))

4271

"If no lock has been supplied, create one. This allows delegates to share with their reference.

4272

If no account is provided, determine it based on the repository's external name

4273

Attempt to establish static authorization if it is known"

4274

(declare (dynamic-extent initargs))

4275

(declare (ignore class)) ;; allow as part of the creation protocol

4276

(setf id (initialize-repository-id instance

4277

(cond ((and account name)

4278

                                             (compute-repository-id account name))

4279

(id)

4280

(t

4281

                                             (error "either account and name or id must be supplied.")))))

4282

4283

(etypecase authorization-list

4284

(null )

4285

(authorization-list )

4286

(cons (setf authorization-list

4287

(make-instance 'authorization-list

4288

:resource instance

4289

:identifier (intern-iri (concatenate 'string "http://" id))

4290

:controls (loop for control in authorization-list

4291

                               collect (apply #'make-instance 'authenticated-authorization

4292

                                              (loop for (property value) on control :by #'cddr

4293

append (list property

4294

                                                             (typecase value

4295

                                                               (string (intern-iri value))

4296

                                                               (t value))))))))))

4297

(with-slots (lock) instance

4298

(unless (slot-boundp instance 'lock)

4299

(setf lock (bt:make-lock id))))

4300

(apply #'call-next-method instance

4301

:title id

4302

:authorization-list authorization-list

4303

initargs))

4304

4305

(defgeneric repository-p (object)

4306

(:method ((repository repository))

4307

t)

4308

(:method ((object t))

4309

nil))

4310

4311

(defgeneric initialize-repository-id (repository id)

4312

(:method :before ((repository repository) (id string))

4313

(assert (or (not (slot-boundp repository 'id))

4314

(equal (slot-value repository 'id) id))

4315

()

4316

"initialize-repository-id: id already set: ~s ~s != ~s"

4317

(type-of repository) id (slot-value repository 'id)))

4318

(:method :around ((repository repository) (id string))

4319

(unless (typep id 'simple-string)

4320

(setf id (subseq id 0)))

4321

(call-next-method repository id))

4322

(:method ((repository repository) (id string))

4323

(multiple-value-bind (account-name repository-name)

4324

(parse-repository-id id)

4325

(assert (and account-name repository-name) ()

4326

"initialize-repository-id: invalid repository-id: ~s" id)

4327

;; ignore variants for service locations beyond the repository name

4328

(setf-repository-repository-name repository-name repository)

4329

(setf-repository-account (account account-name) repository)

4330

(setf-repository-id id repository)))

4331

(:method ((repository remote-repository) (id string))

4332

;;; !!! no validation

4333

(setf-repository-repository-name id repository)

4334

(setf-repository-id id repository)))

4335

4336

(defgeneric repository-last-revision (repository)

4337

(:documentation "Return the last revision ordinal for the repository")

4338

(:method ((repository-id string))

4339

(repository-last-revision (repository repository-id))))

4340

4341

(defmethod initialize-instance ((instance service-repository) &rest initargs &key id account)

4342

"Ensure, that the repository is associated with the respective 'host' account"

4343

(unless account

4344

(destructuring-bind (scheme host &rest path) (split-string id "/:")

4345

(declare (ignore scheme path))

4346

(setf account (account host))))

4347

;; auth is now in the base repository method

4348

;; (print (list :auth id instance authorization-list))

4349

(apply #'call-next-method instance

4350

:account account

4351

initargs))

4352

4353

(defmethod compute-instance-identifier ((instance service-repository))

4354

(intern-iri (concatenate 'string "http://" (repository-id instance))))

4355

4356

(defmethod initialize-instance :after ((instance repository-cache) &key statements)

4357

(when (consp statements)

4358

(loop for (subject predicate object graph) in statements

4359

           do (de.setf.resource:add-statement* instance subject predicate object (or graph '|rdf|:|nil|)))))

4360

4361

(defmethod initialize-instance ((instance repository-revision) &rest args &key

4362

reference

4363

reference-revision-id

4364

revision-id

4365

(name (repository-repository-name reference)))

4366

(declare (dynamic-extent args))

4367

(setf reference (repository reference))

4368

(apply #'call-next-method instance

4369

:id (repository-id reference)

4370

:reference-revision-id (or reference-revision-id

4371

(setf reference-revision-id

4372

                                           (repository-revision-id reference)))

4373

:revision-id (or revision-id (setf revision-id reference-revision-id))

4374

:lock (repository-lock reference)

4375

:match-rate (repository-match-rate reference)

4376

:scan-rate (repository-scan-rate reference)

4377

:name name

4378

:account (repository-account reference)

4379

args)

4380

(flet ((copy-slot (name) (setf (slot-value instance name) (slot-value reference name))))

4381

     #+(or) (mapc #'copy-slot '(bgp-cache aspect-cache statistics used-time uri store->spocq-term-registry))

4382

;; keep the statistics distinct between revision and its reference repository

4383

#+(or) (mapc #'copy-slot '(used-time uri store->spocq-term-registry))

4384

;; the uri is not be that of the base repository

4385

(mapc #'copy-slot '(used-time store->spocq-term-registry))))

4386

4387

(defmethod initialize-clone ((old repository-revision) (new repository-revision) &rest args &key

4388

(revision-id (_slot-value old 'revision-id))

4389

                              (reference-revision-id (_slot-value old 'reference-revision-id)))

4390

(declare (dynamic-extent args))

4391

(let ((reference (repository-revision-reference old)))

4392

(apply #'call-next-method old new

4393

:id (repository-id reference)

4394

:revision-id revision-id

4395

:reference-revision-id reference-revision-id

4396

:reference reference

4397

:lock (repository-lock reference)

4398

args)

4399

(flet ((copy-slot (name) (setf (slot-value new name) (slot-value old name))))

4400

(mapc #'copy-slot '(statistics used-time uri store->spocq-term-registry

4401

bgp-cache aspect-cache match-rate scan-rate

4402

revision-ids)))))

4403

4404

4405

4406

(defgeneric repository-storage-class (repository-id)

4407

(:documentation "Given a repository designator (instance, id or pathname), return the class

4408

of its delegate storage. This matters particulary for thelmdb variants which involve

4409

different sub-databases.")

4410

(:method ((repository-id string))

4411

(let* ((pathname (repository-pathname repository-id)))

4412

(cond (pathname (repository-storage-class pathname))

4413

(t

4414

(error "repository-class: repository not found: ~s" repository-id)))))

4415

(:method ((repository-path pathname))

4416

(if (probe-file repository-path)

4417

;; if the path exists, it's some file-system persisted repository

4418

;; either hdt or a simple repository (rdfcache or lmdb)

4419

(let ((hdt-pathname (repository-hdt-pathname repository-path)))

4420

(if (probe-file hdt-pathname)

4421

;; if an hdt dataset is present

4422

*class.hdt-storage-class*

4423

;; otherwise, examine the environment

4424

(let* ((class-name (or (rlmdb:get-metadata-class repository-path)

4425

*class.lmdb-repository*))

4426

(class (find-class class-name nil)))

4427

(cond (class

4428

(c2mop:ensure-finalized class)

4429

(assert (subtypep class 'repository) ()

4430

                                "repository-storage-class: invalid repository class: ~s" class)

4431

(let ((prototype (class-prototype class)))

4432

(repository-storage-class prototype)))

4433

(t

4434

                        (error "repository-storage-class: invalid repository class: ~s" class-name)))))))))

4435

4436

(defparameter *repository-id-type-map* ()

4437

"Collects type pattern lists to impute the repositry type from its name")

4438

4439

(defparameter *reserved-names* ())

4440

(defun reserved-names ()

4441

(or *reserved-names*

4442

       (setf *reserved-names* (with-open-file (name-stream "reserved_names.txt" :direction :input :if-does-not-exist nil)

4443

(if name-stream

4444

                                    (loop for name = (read-line name-stream nil nil)

4445

until (null name)

4446

collect name)

4447

'("system"))))))

4448

4449

(defgeneric create-repository (repository-id &key if-exists class properties)

4450

(:documentation "Given a id, create a store repository via the cli command.

4451

repository-id : string : the repository identifier in the form account/name

4452

:if-exists : (member nil :error) : when set, signal an error if the repository exists

4453

4454

This should create a persistent rdfcache repository and eventual instantiation depends

4455

on the environment which is constructed.")

4456

4457

(:method ((repository-id string) &rest initargs &key (if-exists :append) (class nil) (properties ())

4458

&allow-other-keys)

4459

"Create the persistent entity which corresponds to the repository instance."

4460

(multiple-value-bind (account repository) (parse-repository-id repository-id)

4461

(when (or (null account)

4462

(null repository)

4463

(member repository (reserved-names) :test #'equalp)

4464

(member account (reserved-names) :test #'equalp))

4465

(error "create-repository: invalid repository id: ~s." repository-id)))

4466

(when class (c2mop:ensure-finalized (find-class class)))

4467

4468

(let ((nominal-type (repository-id-type repository-id)))

4469

(cond (nominal-type

4470

(c2mop:ensure-finalized (find-class nominal-type))

4471

(if class

4472

(assert (subtypep class nominal-type) ()

4473

                          "create-repository: type invalid for name: ~s(~s) ~s" repository-id nominal-type class)

4474

(setf class nominal-type)))

4475

(class

4476

;; ensure it is a repository class

4477

(assert (subtypep class 'repository) ()

4478

"create-repository: invalid class: ~s" class))

4479

(t

4480

(setf class *class.repository*))))

4481

(when (repository-exists-p repository-id)

4482

(case if-exists

4483

(:error (error "create-repository: repository exists: ~s." repository-id))

4484

(:append

4485

;; iff the storage is compatible reuse it.

4486

(let ((repository (repository repository-id)))

4487

(assert (eq class (type-of repository)) ()

4488

                    "Incompatible repository esists: ~s(~s) ~s)" repository-id class repository)

4489

(return-from create-repository (values repository nil))))

4490

(:overwrite

4491

;; truncate the existing repository

4492

(let ((repository (repository repository-id)))

4493

(assert (eq class (type-of repository)) ()

4494

                    "Incompatible repository esists: ~s(~s) ~s)" repository-id class repository)

4495

(clear-repository repository)

4496

(return-from create-repository (values repository nil))))

4497

(:supersede

4498

;; make a new one

4499

(let ((repository (repository repository-id)))

4500

(delete-repository repository)))

4501

((nil)

4502

(return-from create-repository nil))))

4503

;; create the storage without instantiating the repository

4504

(apply #'initialize-repository-storage repository-id class properties)

4505

;;; the server modified the repositories when it first resolves the id to a uuid

4506

;;; !!!???

4507

(rdfcache::resolve-repository repository-id)

4508

(let* ((initargs (remove-properties '(:if-exists :class :properties) initargs))

4509

(repository (apply #'repository repository-id initargs)))

4510

(initialize-repository-metadata repository)

4511

(values repository t))))

4512

4513

(defgeneric validate-storage-class (repository storage)

4514

(:method ((repository t) (storage t))

4515

"Valid repository storage combinations must be declared by defining the respective method"

4516

nil))

4517

4518

(defgeneric clear-repository (repository &key type)

4519

)

4520

4521

(defgeneric initialize-repository-metadata (repository)

4522

(:documentation "ensure that minimal repository metadata are present in the store.

4523

Clear the respective graoh; generate the minimal statements and insert them.")

4524

(:method ((repository t))

4525

repository))

4526

4527

4528

(defgeneric initialize-repository-storage (repository-id class &key)

4529

(:documentation

4530

"Create catalog entries and file-system location given a repository identifier.

4531

This ensures that the directory exists, but not the indices.

4532

That is left to initialization.")

4533

4534

(:method ((repository-id string) (class-name symbol) &rest args &key &allow-other-keys)

4535

(let ((class (find-class class-name)))

4536

(c2mop:ensure-finalized class)

4537

(apply #'initialize-repository-storage repository-id (class-prototype class)

4538

args)))

4539

4540

(:method ((repository-id string) (prototype repository) &key properties &allow-other-keys)

4541

"The base method for repsitories adds an entry to the metadata catalog"

4542

(multiple-value-bind (account-name repository-name) (parse-repository-id repository-id)

4543

(let ((sql-repository (read-sql-repository :name repository-name :account-name account-name))

4544

(uuid nil))

4545

(cond (sql-repository

4546

;; if the sql catalog is present, use its location

4547

(setf uuid (string-downcase (sql-repository-uuid sql-repository))))

4548

(t

4549

;; otherwise create that record

4550

(let ((sql-account (read-sql-account :name account-name)))

4551

(setf uuid (string-downcase (make-v1-uuid-string)))

4552

(setf sql-repository (make-sql-repository

4553

:uuid uuid

4554

:name repository-name

4555

:account sql-account

4556

                                        :account-id (sql-account-id sql-account)

4557

:cached-slug repository-name

4558

:privacy-setting 1)))))

4559

(loop for (property . value) in properties

4560

do (case property

4561

(:license-id (let ((license (gethash (license-registry) value)))

4562

(if license

4563

                                   (setf (sql-repository-license-id sql-repository) license)

4564

(error "Invalid licesne ~s" value))))

4565

                (:default_repository_prefixes (setf (spocq.i::sql-repository-default-repository-prefixes sql-repository) value))

4566

(:description (setf (spocq.i::sql-repository-description sql-repository) value))

4567

(:homepage (setf (spocq.i::sql-repository-homepage sql-repository) value))

4568

                (:permissable_ip_addresses (setf (spocq.i::sql-repository-permissible-ip-addresses sql-repository) value))

4569

                (:privacy_setting (setf (spocq.i::sql-repository-privacy-setting sql-repository) (parse-integer value)))

4570

(:summary (setf (spocq.i::sql-repository-summary sql-repository) value))

4571

((:uuid :name :cached_slug)) ; skip

4572

((nil) )))

4573

(write-sql-repository sql-repository)))

4574

prototype)

4575

4576

(:method ((repository-id string) (prototype file-system-repository) &key &allow-other-keys)

4577

"First, ensure a catalog entry exists, then that the directory exists.

4578

If no catalog entry is present, create it"

4579

(call-next-method)

4580

(multiple-value-bind (account-name repository-name) (parse-repository-id repository-id)

4581

(let ((sql-repository (read-sql-repository :name repository-name :account-name account-name)))

4582

(assert sql-repository ()

4583

"initialize-repository-storage: catalog entry not found: �~s ~s"

4584

account-name repository-name)

4585

;; ensure location exists

4586

(let* ((uuid (string-downcase (sql-repository-uuid sql-repository)))

4587

                (repository-location (merge-pathnames (make-pathname :directory `(:relative "repositories" ,uuid))

4588

                                                      *metadata-root-pathname*))

4589

                (account-location (merge-pathnames (make-pathname :directory `(:relative "accounts" ,account-name))

4590

                                                   *metadata-root-pathname*))

4591

                (link (merge-pathnames (make-pathname :directory `(:relative "accounts" ,account-name "repositories")

4592

                                                      :name repository-name)

4593

*metadata-root-pathname*)))

4594

(assert (probe-file account-location) ()

4595

"initialize-repository-storage: account not found ~s"

4596

account-name)

4597

;; the account catalog entry points to just the simple uuid name

4598

;; nb. osicat:make-link would resolve the simple uuid value

4599

(sb-posix:symlink uuid (namestring link))

4600

(ensure-directories-exist repository-location)))

4601

;; finally, write destription to metadata repositories

4602

(synchronize-repository-from-mysql nil account-name repository-name))

4603

prototype)

4604

4605

#+(or) ;; superseded by file-system-repository method

4606

(:method ((repository-id string) (prototype rdfcache-repository) &key &allow-other-keys)

4607

"Execute the external dydrad mechanism to create the repository database.

4608

Augment its metadata to specify the instance implementation classes."

4609

(call-next-method)

4610

     (let ((process (run-program (admin-executable-pathname) (list "create-repository" repository-id) :wait t)))

4611

(if process

4612

(run-program-close process)

4613

(error "Failed to create repository: ~s." repository-id))

4614

prototype)))

4615

4616

(defgeneric delete-repository (designator &key if-does-not-exist)

4617

(:documentation "Delete the persistent entity which corresponds to the repository instance.")

4618

(:method ((repository-id string) &key (if-does-not-exist nil))

4619

(cond ((repository-exists-p repository-id)

4620

(let ((repository (ignore-errors (repository repository-id))))

4621

(cond (repository

4622

(delete-repository repository))

4623

(t

4624

(ecase if-does-not-exist

4625

(:error (error "repository incomplete: ~s." repository-id))

4626

((nil) (cli-delete-repository repository-id)))))))

4627

(t

4628

(ecase if-does-not-exist

4629

(:error (error "repository not found: ~s." repository-id))

4630

((nil) nil)))))

4631

(:method ((repository repository) &key if-does-not-exist)

4632

(declare (ignore if-does-not-exist))

4633

(multiple-value-bind (account-name repository-name) (parse-repository-id (repository-id repository))

4634

(let ((sql-repository (read-sql-repository :name repository-name :account-name account-name)))

4635

(when sql-repository

4636

(delete-sql-repository sql-repository))))

4637

(prog1 (delete-repository-storage repository)

4638

(setf (repository (repository-id repository)) nil))))

4639

4640

(defgeneric delete-repository-storage (repository)

4641

(:method ((repository-id string))

4642

"Try first to delete the instance in order to remove metdata, but fall back on just

4643

the external storage-"

4644

(let ((repository (ignore-errors (repository repository-id :if-does-not-exist nil))))

4645

(if repository

4646

(delete-repository-storage repository)

4647

(cli-delete-repository repository-id))))

4648

4649

(:method ((repository file-system-repository))

4650

"Delete the persistent storage entity which corresponds to the repository instance."

4651

(call-next-method)

4652

(let* ((uuid (repository-uuid repository))

4653

(repository-id (repository-id repository)))

4654

(multiple-value-bind (account-name repository-name) (parse-repository-id repository-id)

4655

(cond (uuid

4656

                (let ((account-location (merge-pathnames (make-pathname :directory `(:relative "accounts" ,account-name))

4657

                                                         *metadata-root-pathname*)))

4658

(cond ((probe-file account-location)

4659

                         (let* ((repository-location (merge-pathnames (make-pathname :directory `(:relative "repositories" ,uuid))

4660

                                                                      *metadata-root-pathname*))

4661

                                (link (merge-pathnames (make-pathname :directory `(:relative "accounts" ,account-name "repositories")

4662

                                                                      :name repository-name)

4663

                                                       *metadata-root-pathname*))

4664

                                (remove-to-location (make-pathname :directory (append (butlast (pathname-directory *metadata-root-pathname*))

4665

                                                                                      (list ".removals" uuid)))))

4666

(delete-file (namestring link))

4667

(rename-file repository-location remove-to-location)

4668

repository))

4669

(t

4670

                         (log-warn "delete-repository-storage: account not found: ~s" account-name)

4671

nil))))

4672

(t

4673

                (log-warn "delete-repository-storage: repository not found: ~s ~s" account-name repository-name)

4674

nil)))))

4675

4676

(:method ((repository repository))

4677

"The base method deletes just the metadata"

4678

;;!! should delete the relational metadata as well

4679

(delete-repository-metadata repository)

4680

repository))

4681

4682

(defgeneric repository-storage (repository)

4683

(:documentation "Return the respective implementation instance"))

4684

4685

(defgeneric storage-metadata (repository)

4686

(:documentation "Return the respective implementation instance's metadata")

4687

(:method ((repository repository))

4688

(let ((storage (repository-storage repository)))

4689

(when storage (storage-metadata storage)))))

4690

4691

(defmethod repository-revision-reference ((repository repository))

4692

"If it is a base repository, there is no reference"

4693

nil)

4694

4695

(defgeneric repository-revision-class (repository)

4696

(:method ((class symbol)) (repository-revision-class (find-class class)))

4697

(:method ((class standard-class))

4698

(c2mop:ensure-finalized class)

4699

(repository-revision-class (c2mop:class-prototype class))))

4700

4701

(defmethod print-object ((object repository) (stream t) &aux (*print-pretty* nil))

4702

(_print-unreadable-object (object stream :identity t :type t)

4703

(format stream "~a (~a)"

4704

(bound-slot-value object 'id)

4705

(bound-slot-value object 'repository-name))))

4706

4707

(defun print-repositories ()

4708

(print (repositories)))

4709

4710

(defun repositories ()

4711

(loop for repository being each hash-value of *repositories*

4712

collect repository))

4713

4714

(defmethod print-object ((object repository-revision) (stream t) &aux (*print-pretty* nil))

4715

(_print-unreadable-object (object stream :identity t :type t)

4716

(let* ((revision-id (bound-slot-value object 'revision-id))

4717

(reference-revision-id (bound-slot-value object 'reference-revision-id)))

4718

(format stream "~a-~a~@[(~a)~]~@[[~/format-iso-time/-~@[~/format-iso-time/~])~]"

4719

(bound-slot-value object 'id)

4720

revision-id

4721

(unless (equal revision-id reference-revision-id) reference-revision-id)

4722

(bound-slot-value object 'start-date-time)

4723

(bound-slot-value object 'end-date-time)))))

4724

4725

(defmethod format-iso-time (stream (datetime spocq:date-time) &optional colon at var)

4726

(format-iso-time stream (date-time-universal-time datetime)

4727

colon at var))

4728

4729

(defgeneric repository-identifier (repository)

4730

(:method ((repository repository))

4731

(instance-identifier repository)))

4732

4733

(defgeneric repository-uri (repository)

4734

(:method ((repository repository))

4735

(resource-uri repository))

4736

(:method ((revision repository-revision))

4737

(repository-uri (repository-revision-reference revision))))

4738

4739

(defgeneric repository-base-iri (repository)

4740

(:documentation "return an iri to be used to parse query documentation in relation

4741

to the repository. should yield its service location url")

4742

(:method ((repository repository))

4743

(or (repository-uri repository) (base-iri)))

4744

(:method ((repository t))

4745

(base-iri)))

4746

4747

(defmethod resource-pathname-element ((repository spocq.i:repository))

4748

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

4749

4750

(defgeneric repository-uuid (repository)

4751

(:documentation "This is value constitutes the permanent identifier for a repository,

4752

independent of any change to its name. For rdfcache-related repositories, it is captured

4753

in the service catalog. For others it is generated from the context."))

4754

4755

4756

(defmethod resource-authorization-list ((resource repository-revision))

4757

"for a revision, use one which has been supplied explcitly, or delegate to the reference

4758

repository, but do not cache in order to ensure updates."

4759

(or (get-resource-authorization-list resource)

4760

(resource-authorization-list (repository-revision-reference resource))))

4761

4762

(defmethod instance-metadata ((instance repository-revision))

4763

(instance-metadata (repository-revision-reference instance)))

4764

4765

#+(or) ;; eliminated in favor of adding logic for the two cases (read, write) at those sites

4766

(

4767

(defmethod align-resource-to-store ((resource persistent-object) (repository repository)

4768

                                     &key (revision (repository-last-revision repository)))

4769

(setf (instance-store-revision resource) revision)

4770

(setf (instance-state resource)

4771

;; :clean or :new depending on whether it exists in the store.

4772

;; no, this causes each access to a new instance to try to resync

4773

;; (if (get-instance-store-graph resource) :clean :new)

4774

:clean)

4775

resource)

4776

4777

(defmethod align-resource-to-store ((resource persistent-object) (reference transaction) &key (revision nil))

4778

(unless revision

4779

(setf revision

4780

(if (transaction-read-only-p reference)

4781

(transaction-revision-id reference)

4782

(transaction-id reference))))

4783

(align-resource-to-store resource (transaction-revision reference) :revision revision))

4784

4785

(defmethod align-resource-to-store ((resource persistent-object) (reference string) &rest args)

4786

(declare (dynamic-extent args))

4787

(apply #'align-resource-to-store resource (repository reference) args)))

4788

4789

;;; nb. repository-id and repository-identifier are _not_ the same

4790

;;; the first is a two part string and the second an iri with http compnents

4791

4792

(defgeneric compute-repository-id (account repository)

4793

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

4794

(concatenate 'string account-name "/" repository-name))

4795

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

4796

(compute-repository-id (account-name account) repository))

4797

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

4798

(compute-repository-id account (repository-name repository))))

4799

4800

(defgeneric compute-repository-identifier (account repository)

4801

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

4802

     (intern-iri (concatenate 'string "http" "://" (site-name) "/accounts/" account-name "/repositories/" repository-name)))

4803

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

4804

(compute-repository-identifier (account-name account) repository))

4805

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

4806

(compute-repository-identifier account (repository-name repository))))

4807

4808

(defgeneric compute-repository-uri (account repository)

4809

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

4810

     (intern-iri (concatenate 'string *site-protocol* "://" (host-name) "/" account-name "/" repository-name)))

4811

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

4812

(compute-repository-uri (account-name account) repository))

4813

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

4814

(compute-repository-uri account (repository-name repository))))

4815

4816

(defgeneric compute-repository-admin-uri (account repository)

4817

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

4818

     (intern-iri (concatenate 'string *site-protocol* "://" (host-name) "/system/accounts/"  account-name "/repositories/" repository-name)))

4819

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

4820

(compute-repository-admin-uri (account-name account) repository))

4821

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

4822

(compute-repository-admin-uri account (repository-name repository))))

4823

4824

(defmethod compute-instance-identifier ((repository repository))

4825

(compute-repository-identifier (repository-account repository) repository))

4826

4827

(defgeneric repository-admin-uri (repository)

4828

(:method ((repository repository))

4829

(compute-repository-admin-uri (repository-account repository)

4830

(repository-name repository))))

4831

4832

(defmethod (setf repository-license) ((license string) (resource repository))

4833

(if (url-string-p license)

4834

(setf (repository-license resource) (spocq.i::intern-iri license))

4835

(error 'type-error :expected-type 'url-string :datum license)))

4836

4837

4838

(defun repository-id-type (repository-id)

4839

(loop for (type pattern) in *repository-id-type-map*

4840

when (cl-ppcre:scan pattern repository-id)

4841

return type))

4842

4843

(defgeneric repository-type (repository-id)

4844

(:documentation "Given a repository designator (instance, id or pathname),

4845

Attempt to determine the respective class.

4846

As declared, for a repository which is defined in the system configuration,

4847

HDT repositories, based on the presence of .hdt files,

4848

LMDB, for other repositories which are present in the file system,

4849

archives baed on prsence of the sub-databases

4850

views based on metadata for the source

4851

various, by name syntax

4852

otherwise the NIL.")

4853

(:method ((repository repository))

4854

(type-of repository))

4855

4856

(:method ((repository-id string))

4857

"Given a string id, first use the id pattern

4858

Then look at any persistent storage in order

4859

to see what might have been asserted independent of name pattern."

4860

4861

(or (let* ((pathname (repository-pathname repository-id)))

4862

(cond (pathname (repository-type pathname))

4863

(t

4864

nil)))

4865

(repository-id-type repository-id)))

4866

4867

(:method ((repository-path pathname))

4868

;; when the path exists, it's some file-system persisted repository

4869

(when (probe-file repository-path)

4870

;; when the path exists, it's some file-system persisted repository

4871

;; either hdt, rdfcache or some lmdb variant (even a virtual form)

4872

(let ((metadata (rlmdb:get-metadata repository-path)))

4873

;; examine the metadata

4874

(let* ((class (rest (assoc :class metadata :test #'string-equal))))

4875

(cond ((eq class 'lmdb-repository)

4876

*class.lmdb-repository*)

4877

(class

4878

(c2mop:ensure-finalized (or (find-class class nil)

4879

                                              (error "repository-type: invalid repository class: ~s" class)))

4880

(cond ((subtypep class 'repository)

4881

class)

4882

(t

4883

                         (log-warn "repository-class: ignoring invalid repository class: ~s" class)

4884

nil)))

4885

;; examine the environment

4886

((repository-is-hdt repository-path)

4887

;; if an hdt dataset is present

4888

*class.hdt-repository*)

4889

((repository-is-replicable metadata)

4890

*class.replicable-repository*)

4891

((repository-is-revisioned metadata)

4892

*class.revisioned-repository*)

4893

((repository-is-view metadata)

4894

*class.internal-view-repository*)

4895

(t

4896

nil)))))))

4897

4898

(defgeneric repository (class &key id

4899

&allow-other-keys)

4900

(:documentation "GIven a designator - a repository id string, either retrieve the known instance

4901

     or create a new one and register it in *repositories*. Instantiation relies on the current value

4902

for *class.repository* and verifies the result.

4903

     nb. It is not sufficient to set the used timestamp here, as a re-run query should do it as well.")

4904

4905

(:method ((designator t) &rest args)

4906

(error "invalid repository designator: ~s . ~s" designator args))

4907

4908

(:method ((class symbol) &rest args)

4909

(declare (dynamic-extent args))

4910

(assert class () "Invalid repository id: ~s." class)

4911

(apply #'repository (find-class class) args))

4912

4913

(:method ((class class) &rest args)

4914

(declare (dynamic-extent args))

4915

(repository (apply #'make-instance class args)))

4916

4917

(:method ((repository repository) &key &allow-other-keys)

4918

(setf (repository-used-time repository) (get-universal-time))

4919

repository)

4920

4921

(:method ((transaction transaction) &key &allow-other-keys)

4922

(let ((revision (transaction-revision transaction)))

4923

(when revision (repository-revision-reference revision))))

4924

4925

(:method ((repository-id string) &rest args &key

4926

(if-does-not-exist :error)

4927

(external-name nil en-s)

4928

(class nil))

4929

(declare (dynamic-extent args)

4930

(ignore external-name))

4931

(log-debug "repository: get: ~s" repository-id)

4932

(cond ((get-registry repository-id *repositories*) )

4933

((get-registry repository-id *built-in-repositories*) )

4934

((or (repository-exists-p repository-id)

4935

(eq :create if-does-not-exist))

4936

(log-debug "repository: get.test: ~s" repository-id)

4937

(with-locked-registry (*repositories*)

4938

;; with exclusive access, recheck that it was not yet created

4939

;; if still absent, create it

4940

(cond ((get-registry repository-id *repositories*))

4941

(t

4942

(log-debug "repository: get.locked: ~s" repository-id)

4943

(when (not en-s)

4944

(setf args (list* :external-name repository-id args)))

4945

(cond ((and class (find-class class nil))

4946

(unless (subtypep class 'repository)

4947

                              (log-warn "repository: invalid repository class: ~s: ~s" repository-id class)

4948

(setf class *class.lmdb-repository*)))

4949

(t

4950

(setf class (cond ((repository-type repository-id))

4951

(t

4952

                                               (log-info "repository-class: defaulting repository class: ~s: ~s"

4953

                                                         (repository-pathname repository-id)

4954

class)

4955

                                               *class.lmdb-repository*)))))

4956

(let ((new (apply #'repository class

4957

:id repository-id

4958

                                       (remove-properties '(:if-does-not-exist) args))))

4959

(log-debug "repository: new: ~s ~s" repository-id new)

4960

(when new

4961

(setf (get-registry repository-id *repositories*) new))

4962

new)))))

4963

(t

4964

(ecase if-does-not-exist

4965

(:error (spocq.e:repository-not-found-error :identifier repository-id))

4966

((nil) nil))))))

4967

4968

(defgeneric (setf repository) (repository id)

4969

(:method ((repository repository) (id string))

4970

(setf (get-registry id *repositories*) repository))

4971

(:method ((repository null) (id string))

4972

(rem-registry id *repositories*)

4973

nil))

4974

4975

(defgeneric static-repository (repository)

4976

(:documentation "resolve the given value the the respective base repository")

4977

(:method ((repository repository-revision))

4978

"coerce a revision back to its base"

4979

(repository-revision-reference repository))

4980

(:method ((repository repository))

4981

repository)

4982

(:method ((repository t))

4983

(static-repository (repository repository))))

4984

4985

4986

(defun find-repository (id)

4987

(get-registry id *repositories*))

4988

4989

(defun system-repository ()

4990

(unless (null-sequence-p *system-repository-id*)

4991

(repository *system-repository-id*)))

4992

4993

(defgeneric map-repository-contexts (function repository &key distinct default)

4994

(:method map-repository-contexts (function (repository-handle repository-cache) &key distinct default)

4995

(declare (ignore distinct))

4996

(loop for context being each hash-key of (cache-index-c repository-handle)

4997

unless (or default (not (default-context-p context)))

4998

do (funcall function context))))

4999

5000

(defgeneric map-repository-subjects (function repository-handle &key context distinct)

5001

(:documentation

5002

     "Given an operator and a repository/transaction/connection, map the operator over the subject term numbers.")

5003

5004

(:method (function (repository repository-cache) &key context distinct)

5005

(declare (ignore distinct))

5006

(if (null context)

5007

(loop for subject being each hash-key of (cache-index-s repository)

5008

do (funcall function subject))

5009

(loop for subject being each hash-key of (cache-index-s repository)

5010

using (hash-value statements)

5011

if (find context statements :test #'spocq.e:same-term :key #'triple-graph)

5012

do (funcall function subject)))))

5013

5014

(defgeneric map-repository-predicates (function repository-handle &key context distinct)

5015

(:documentation

5016

     "Given an operator and a repository/transaction/connection, map the operator over the predicate term numbers.")

5017

5018

(:method (function (repository repository-cache) &key context distinct)

5019

(declare (ignore distinct))

5020

(if (null context)

5021

(loop for predicate being each hash-key of (cache-index-p repository)

5022

do (funcall function predicate))

5023

(loop for predicate being each hash-key of (cache-index-p repository)

5024

using (hash-value statements)

5025

if (find context statements :test #'spocq.e:same-term :key #'triple-graph)

5026

do (funcall function predicate)))))

5027

5028

(defgeneric map-repository-objects (function repository-handle &key context distinct)

5029

(:documentation

5030

     "Given an operator and a repository/transaction/connection, map the operator over the object term numbers.")

5031

5032

(:method (function (repository repository-cache) &key context distinct)

5033

(declare (ignore distinct))

5034

(if (null context)

5035

(loop for object being each hash-key of (cache-index-o repository)

5036

do (funcall function object))

5037

(loop for object being each hash-key of (cache-index-o repository)

5038

using (hash-value statements)

5039

if (find context statements :test #'spocq.e:same-term :key #'triple-graph)

5040

do (funcall function object)))))

5041

5042

5043

(defgeneric map-repository-statements (function transaction subject predicate object context &rest args)

5044

(:documentation "Given a repository/transaction/connection iterate over the

5045

statements which match an s-p-o-c term-id constraint constraint, extract all

5046

matches, and invoke the given operator on the term numbers."))

5047

5048

(defgeneric repository-connection (repository)

5049

(:documentation "Return an implementation resource which connects the instance

5050

repository with back-end processing. eg for odbc-based repositories.

5051

This sould apply in special cases only, as the connection is likely not thread-safe.

5052

The with-repository-connection is intended formulti-threaded operations")

5053

(:method ((repository t))

5054

"the default method yields no connection"

5055

nil))

5056

5057

(defmacro with-repository-connection ((connection repository) &body body)

5058

(let ((op (gensym "wrc-")))

5059

`(flet ((,op (,connection) ,@body))

5060

(declare (dynamic-extent #',op))

5061

(call-with-repository-connection #',op ,repository))))

5062

5063

(defgeneric call-with-repository-connection (op repository)

5064

(:argument-precedence-order repository op))

5065

5066

5067

(defgeneric repository-description (repository)

5068

(:method ((repository repository))

5069

(fourth (find |dc|:|description| (instance-metadata-statements repository) :key #'third))))

5070

5071

(defgeneric repository-statement-count (repository)

5072

(:method ((id string))

5073

(repository-statement-count (repository id)))

5074

(:method ((transaction transaction))

5075

(repository-statement-count (transaction-revision transaction)))

5076

(:method ((revision repository-revision))

5077

(let ((reference (repository-revision-reference revision)))

5078

(if reference

5079

(repository-statement-count reference)

5080

1)))

5081

(:method ((repository repository))

5082

(or (get-repository-statement-count repository)

5083

(setf-repository-statement-count (if (repository-revision-id repository)

5084

                                            (read-repository-statement-count repository)

5085

1)

5086

repository))))

5087

5088

5089

(defgeneric repository-pattern-count (transaction subject predicate object context)

5090

;; first context for multiples, then predicate for paths, then transaction...

5091

(:argument-precedence-order predicate context transaction subject object)

5092

5093

(:method (transaction subject predicate object (context cons))

5094

(loop for context in context

5095

sum (repository-pattern-count transaction subject predicate object context)))

5096

5097

(:method ((repository null) (subject t) (predicate t) (object t) (context t))

5098

0)

5099

(:method ((id string) (subject t) (predicate t) (object t) (context t))

5100

(repository-pattern-count (repository id) subject predicate object context))

5101

)

5102

5103

5104

#+(or)

5105

 (defmethod set-instance-metadata-parameter ((instance repository) subject (predicate (eql |rdfs|:|range|)) object)

5106

"given a type assertion, cache the respective type declaration"

5107

(let ((metadata (instance-metadata instance)))

5108

(setf (getf (repository-metadata-type-declarations metadata) subject) object)))

5109

5110

5111

(defgeneric repository-metadata-file (repository)

5112

(:documentation "read the saved metadatafile for the repository as an a-list")

5113

(:method ((repository-id string))

5114

(repository-metadata-file (repository repository-id))))

5115

5116

(defun print-repository-resources ()

5117

(sort (loop for repo being each hash-value in *repositories*

5118

collect repo)

5119

#'string-lessp

5120

:key #'repository-id))

5121

5122

(defgeneric release-repository-resources (object)

5123

(:documentation "examine repository-related resource to purge those not in use.

5124

this concerns primarily revisions, as they collect the terms caches and accumulate as

5125

updates occur. repositories themselves are retained, as otherwise revisions may reference

5126

a stale repository instance.")

5127

(:method ((repository t))

5128

(log-warn "release-repository-resources: invalid repository registered: ~s." repository))

5129

(:method ((registry hash-table))

5130

(let* ((now (get-universal-time ))

5131

(threshold (- now *repository-time-to-live*))

5132

(ids-to-delete ()))

5133

(flet ((mark-repository (query)

5134

(let ((repository (task-repository query)))

5135

(when repository (setf (repository-used-time repository) now)))))

5136

(declare (dynamic-extent #'mark-repository))

5137

(map-queries #'mark-repository)

5138

;; first delete old ones....

5139

(when (setf ids-to-delete

5140

(loop for repository being each hash-value in registry

5141

using (hash-key id)

5142

if (and (typep repository 'repository-revision)

5143

                                   (< (repository-used-time repository) threshold))

5144

collect id))

5145

(dolist (id ids-to-delete)

5146

(rem-registry id registry)))

5147

;; then prune

5148

(when (> (hash-table-count registry) *repository-limit*)

5149

(loop for (time . id)

5150

in (butlast

5151

;;;!!! this should prune revisions only.

5152

(sort (loop for repository being each hash-value in registry

5153

using (hash-key id)

5154

when (typep repository 'repository-revision)

5155

collect (cons (repository-used-time repository) id))

5156

#'< :key #'first)

5157

*repository-limit*)

5158

do (progn (push id ids-to-delete)

5159

(rem-registry id registry))))

5160

;; then reduce caches on those which remain

5161

(loop for repository being each hash-value in registry

5162

using (hash-key id)

5163

do (if repository

5164

(release-repository-resources repository)

5165

                  (log-warn "release-repository-resources: invalid repository registered: ~s." id))))

5166

ids-to-delete))

5167

5168

(:method ((repository repository))

5169

(flet ((prune-registry (registry limit)

5170

(when (> (hash-table-count registry) limit)

5171

(let ((keys-to-remove (loop for key being each hash-key of registry

5172

for count from 0

5173

when (evenp count)

5174

collect key)))

5175

(when keys-to-remove

5176

(log-info "pruned repository registry ~s ~s of ~d / ~d"

5177

                              repository registry (length keys-to-remove) (hash-table-count registry)))

5178

(dolist (key keys-to-remove)

5179

(rem-registry key registry))

5180

keys-to-remove))))

5181

(list (prune-registry (repository-bgp-cache repository) *repository-bgp-limit*)

5182

(prune-registry (repository-aspect-cache repository) *repository-aspect-limit*)))))

5183

;;; (release-repository-resources *repositories*)

5184

5185

(defmethod (setf repository-used-time) :after (time (repository repository-revision))

5186

(setf (repository-used-time (repository-revision-reference repository))

5187

(repository-used-time repository)))

5188

5189

(defun make-repository-index () (make-hash-table :test 'equal))

5190

5191

(defgeneric repository-id (context)

5192

(:documentation "The repository id designates the repository as a whol in terms of the account

5193

and the repository numbers. These are projections from the account and repository names.")

5194

(:method ((task data-task))

5195

(repository-id (task-repository task)))

5196

(:method ((id string))

5197

id))

5198

5199

(defparameter *warn-on-null-revision-id* nil)

5200

5201

(defgeneric repository-revision-id (repository)

5202

(:documentation "The repository revision id designates a particular state at a point in time and

5203

     dependent on the repository instance modification history. Each is a uuid which is generated when the

5204

     revision is commited. If the repository is empty - that is, there is no revision, return two values,

5205

nil and the repository primary id.")

5206

(:method ((revision repository-revision))

5207

(let ((id (bt:with-lock-held ((repository-lock revision))

5208

(or (get-repository-revision-id revision)

5209

                     (setf-repository-revision-id (resolve-repository-revision-id revision) revision)))))

5210

(cond (id )

5211

(t

5212

(when *warn-on-null-revision-id*

5213

(log-warn "revision id resolves to nil: ~s" revision))

5214

(resolve-repository-revision-id (repository-revision-reference revision))))))

5215

(:method ((repository repository))

5216

(resolve-repository-revision-id repository))

5217

(:method ((task data-task))

5218

(repository-revision-id (task-revision task)))

5219

(:method ((id string))

5220

(repository-revision-id (repository id))))

5221

5222

(defgeneric repository-revision-date-time (revision)

5223

(:documentation "return the ned data-time for the revision.

5224

for anything else, fallback to the current time")

5225

(:method ((repository-revision t))

5226

(spocq.e:now))

5227

(:method ((repository-revision repository-revision))

5228

(repository-revision-end-date-time repository-revision)))

5229

5230

(defgeneric repository-revision-start-date-time (revision)

5231

(:method ((revision repository-revision))

5232

(or (repository-revision-get-start-date-time revision)

5233

(let* ((id (repository-revision-id revision))

5234

                (metadata-list (repository-list-revision-metadata (repository-revision-reference revision)))

5235

                (end-metadata-list (member id (reverse metadata-list) :test #'equalp :key #'first)))

5236

(when end-metadata-list

5237

(let* ((end-metadata (first end-metadata-list))

5238

(start-metadata (or (second end-metadata-list) end-metadata))

5239

(end-date-time (timeline-location-date-time (second end-metadata)))

5240

(start-date-time (timeline-location-date-time (second start-metadata))))

5241

(setf (slot-value revision 'end-date-time) end-date-time

5242

(slot-value revision 'start-date-time) start-date-time)))))))

5243

5244

(defgeneric repository-revision-end-date-time (revision)

5245

(:method ((revision repository-revision))

5246

(or (repository-revision-get-end-date-time revision)

5247

(let* ((id (repository-revision-id revision))

5248

                (metadata-list (repository-list-revision-metadata (repository-revision-reference revision)))

5249

                (end-metadata-list (member id (reverse metadata-list) :test #'equalp :key #'first)))

5250

(when end-metadata-list

5251

(let* ((end-metadata (first end-metadata-list))

5252

(start-metadata (or (second end-metadata-list) end-metadata))

5253

(end-date-time (timeline-location-date-time (second end-metadata)))

5254

(start-date-time (timeline-location-date-time (second start-metadata))))

5255

(setf (slot-value revision 'start-date-time) start-date-time

5256

(slot-value revision 'end-date-time) end-date-time)))))))

5257

5258

5259

5260

(defun initialize-built-in-repositories ()

5261

;; set up and configured materialized repositories

5262

(loop for repository-id in *materialized-repositories*

5263

for table-id = (substitute #\. #\/ repository-id)

5264

do (setf (gethash repository-id *built-in-repositories*)

5265

(multiple-value-bind (account name) (parse-repository-id repository-id)

5266

(declare (ignore name))

5267

(make-instance 'internal-materialized-repository

5268

:id repository-id

5269

:account (account account)

5270

:view-database (SPOCQ::make-POSTGRESQL-URI :ID NIL

5271

                                                             ;; :LEXICAL-FORM "postgresql://postgres:postgres@localhost/test?table=query_events&schema=views"

5272

:USER "postgres"

5273

:PASSWORD "postgres"

5274

:AUTHORITY "localhost"

5275

:PORT NIL

5276

                                                :DATABASE *MYSQL-DATABASE*  ;; postgres name same as mysql

5277

                                                :PARAMETERS `((:TABLE . ,table-id) (:SCHEMA . "views")))))))

5278

;; set up the operations repositories

5279

(setf (gethash "operations/query_events" *built-in-repositories*)

5280

(make-instance 'external-materialized-repository

5281

:id "operations/query_events"

5282

:account (account "operations") :name "query_events"

5283

           ;; :view-database <postgresql://postgres:postgres@localhost/test?table=query_events&schema=accounting>

5284

:view-database (SPOCQ::make-POSTGRESQL-URI :ID NIL

5285

                                                ;; :LEXICAL-FORM "postgresql://postgres:postgres@localhost/test?table=query_events&schema=operations"

5286

:USER "postgres"

5287

:PASSWORD "postgres"

5288

:AUTHORITY "localhost"

5289

:PORT NIL

5290

                                                :DATABASE *MYSQL-DATABASE*

5291

                                                :PARAMETERS '((:TABLE . "query_events") (:SCHEMA . "operations")))))

5292

(unless (repository-pathname "operations/query_events")

5293

(log-warn "built in repository not present: operations/query_events"))

5294

(setf (gethash "operations/transaction_events" *built-in-repositories*)

5295

(make-instance 'external-materialized-repository

5296

:id "operations/transaction_events"

5297

:account (account "operations") :name "transaction_events"

5298

:view-database (SPOCQ::make-POSTGRESQL-URI :ID NIL

5299

                                                ;; :LEXICAL-FORM "postgresql://postgres:postgres@localhost/test?table=transaction_events&schema=operations"

5300

:USER "postgres"

5301

:PASSWORD "postgres"

5302

:AUTHORITY "localhost"

5303

:PORT NIL

5304

                                                :DATABASE *MYSQL-DATABASE*

5305

                                                :PARAMETERS '((:TABLE . "transaction_events") (:SCHEMA . "operations")))))

5306

(unless (repository-pathname "operations/transaction_events")

5307

(log-warn "built in repository not present: operations/transaction_events"))

5308

;;; import events is a mysql view

5309

(setf (gethash "operations/import_events" *built-in-repositories*)

5310

(make-instance 'external-materialized-repository

5311

:id "operations/import_events"

5312

:account (account "operations") :name "import_events"

5313

:view-database (SPOCQ::make-mysql-URI :ID NIL

5314

:USER "production"

5315

                                                 :PASSWORD "X5lhSMNlJVlK4O1d"

5316

                                                 :AUTHORITY "localhost"

5317

:PORT NIL

5318

                                                 :DATABASE *MYSQL-DATABASE*

5319

                                                 :TABLE "import_events"

5320

                                                 :PARAMETERS `((:SCHEMA . ,*MYSQL-DATABASE*)))))

5321

(unless (repository-pathname "operations/import_events")

5322

(log-warn "built in repository not present: operations/import_events"))

5323

(setf (gethash "operations/accounts" *built-in-repositories*)

5324

(make-instance 'external-materialized-repository

5325

:id "operations/accounts"

5326

:account (account "operations") :name "accounts"

5327

:view-database (SPOCQ::make-mysql-URI :ID NIL

5328

:USER "production"

5329

                                                 :PASSWORD "X5lhSMNlJVlK4O1d"

5330

                                                 :AUTHORITY "localhost"

5331

:PORT NIL

5332

                                                 :DATABASE *MYSQL-DATABASE*

5333

:TABLE "accounts"

5334

                                                 :PARAMETERS `((:SCHEMA . ,*MYSQL-DATABASE*)))))

5335

(unless (repository-pathname "operations/accounts")

5336

(log-warn "built in repository not present: operations/accounts"))

5337

5338

t)

5339

;;; (initialize-built-in-repositories)

5340

;;; (repository "operations/import_events")

5341

#|

5342

scp -P 2200 de8.dydra.com:/srv/dydra/backups/imports-view.sql /srv/dydra/backups/

5343

scp -P 2200 de8.dydra.com:/srv/dydra/backups/event-schema.sql /srv/dydra/backups/

5344

mysql "${RAILS_ENV}" < /srv/dydra/backups/imports-view.sql

5345

sudo -u postgres psql "${RAILS_ENV}" < /srv/dydra/backups/event-schema.sql

5346

scp de10.dydra.com:/opt/dydra/lib/clsql_mysql64.so /opt/dydra/lib/

5347

|#

5348

5349

5350

5351

(defgeneric update-repository-revision-id (task)

5352

(:documentation

5353

"re-resolve the task repository revision id. if it has changed, then replace the

5354

task's revision with the current ont.")

5355

5356

(:method ((task data-task))

5357

(let ((revision (task-revision task)))

5358

(multiple-value-bind (new-id old-id) (resolve-repository-revision-id revision)

5359

(when (and old-id (not (equal new-id old-id)))

5360

(setf (task-revision task)

5361

                 (setf revision (repository-revision new-id :reference (task-repository task))))))

5362

revision)))

5363

5364

(defgeneric repository-revision-reference-revision-id (revision)

5365

(:method ((repository repository))

5366

(resolve-repository-revision-id repository)))

5367

5368

(defgeneric repository-aspect-cache (repository)

5369

(:method ((repository null))

5370

nil))

5371

5372

(defgeneric repository-bgp-cache (repository)

5373

(:method ((repository null))

5374

nil))

5375

5376

5377

5378

(defgeneric repository-enabled-p (repository)

5379

(:method ((repository-id string))

5380

(not (find repository-id *disabled-repositories* :test #'string-equal)))

5381

(:method ((repository repository))

5382

(repository-enabled-p (repository-id repository))))

5383

5384

(defgeneric repository-named-contexts-term (repository)

5385

(:method ((repository repository))

5386

(metadata-named-contexts-term repository)))

5387

5388

(defgeneric repository-named-contexts-term-number (repository)

5389

(:method ((transaction transaction))

5390

(repository-object-term-number transaction (repository-named-contexts-term transaction)))

5391

(:method ((repository repository))

5392

(repository-object-term-number repository (repository-named-contexts-term repository))))

5393

5394

(defgeneric repository-clear-caches (repository)

5395

(:method ((repository repository))

5396

(setf-repository-statement-count nil repository)

5397

(setf-repository-provenance-information nil repository)

5398

(clear-registry (repository-aspect-cache repository))

5399

(clear-registry (repository-bgp-cache repository))

5400

(clear-registry (repository-statistics repository))))

5401

5402

(defgeneric repository-scan-rate (repository)

5403

(:method ((transaction rdfcache-transaction))

5404

(repository-scan-rate (transaction-repository transaction))))

5405

5406

(defgeneric repository-match-rate (repository)

5407

(:method ((transaction rdfcache-transaction))

5408

(repository-match-rate (transaction-repository transaction))))

5409

5410

(defgeneric repository-term-deconstructor (repository)

5411

(:documentation "Specialized for a repository and/or a transaction context

5412

to return an operator of three arguments, a function, a context, and a term number.

5413

the deconstruction operator resolves the number in the current transaction

5414

context to the terms respective aspects and applies the given operator

5415

to them."))

5416

5417

(defgeneric repository-call-with-numbered-term-aspects (operator repository term-number)

5418

)

5419

5420

5421

#+(or)

5422

(defgeneric repository-rule-set (repository rule-set)

5423

(:documentation "Load a rewrite rules set in the context of a repository.

5424

5425

The source for the entailment rules can be

5426

  - in an explicitly named repository from the same account. permit the uri to designate a graph within the repository.

5427

- in the system-wide entailment repository in the designated graph.

5428

- in the document on a remote host.

5429

5430

Each element is an IRI, which must designate a resource which comprises a set of rules. ")

5431

5432

(:method ((repository repository) (rule-set spocq:iri))

5433

(or (find rule-set (repository-rule-sets repository) :key #'rule-set-name)

5434

(flet ((make-rule-set ()

5435

(let* ((iri-namestring (spocq:iri-lexical-form rule-set))

5436

(structured-iri (puri:uri iri-namestring))

5437

(host (puri:uri-host structured-iri))

5438

(path (split-string (puri:uri-path structured-iri) "/"))

5439

(account-name (pop path))

5440

(repository-name (pop path))

5441

(repository-id (repository-id repository)))

5442

                    (cond ((string-equal host (host-name) :start2 (max 0 (- (length (host-name)) (length host))))

5443

                           (let* ((entailment-repository-id (lookup-repository-id :account-name account-name :repository-name repository-name)))

5444

(cond ((equal repository-id entailment-repository-id)

5445

                                    ;; read it from a graph in the same repository

5446

                                    (read-repository-rule-set repository rule-set))

5447

((equal (parse-repository-id repository-id)

5448

                                           (parse-repository-id entailment-repository-id))

5449

;; check just the account, then

5450

                                    ;; read it from a graph in the specific repository from the same account

5451

                                    (read-repository-rule-set (repository entailment-repository-id) rule-set))

5452

                                   ((equal (entailment-repository-id) entailment-repository-id)

5453

                                    ;; read it from a locally curated graph in the entailment regime repository

5454

                                    (read-repository-rule-set (repository (entailment-repository-id)) rule-set))

5455

(t

5456

                                    ;; cross-loading from other account's repositories is not permitted

5457

                                    (error "Invalid rule set repository: ~a." rule-set)))))

5458

(t

5459

                           ;; ensure that the graph is present in the system-wide repository and load that

5460

                           (let ((entailment-repository (repository (entailment-repository-id))))

5461

                             (read-repository-rule-set entailment-repository rule-set)))))))

5462

(push (make-rule-set) (repository-rule-sets repository))))))

5463

5464

5465

(defgeneric read-repository-rule-set (repository rule-set-designator)

5466

   (:documentation "Given a repository and a rule set resource identifier, read the rule set from the store

5467

as a sequence of triples and transform them into the equivalent construct forms."))

5468

5469

#+(or)

5470

(defgeneric repository-entailed-predicate (repository subject predicate object)

5471

(:method ((repository repository) (subject t) (predicate (eql |rdf|:|type|)) (object spocq:iri))

5472

(gethash (spocq:iri-lexical-form object) (repository-entailment-cache repository)))

5473

(:method ((repository repository) (subject t) (predicate (eql |rdf|:|type|)) (object symbol))

5474

(gethash (symbol-uri-namestring object) (repository-entailment-cache repository)))

5475

5476

(:method ((repository repository) (subject t) (predicate spocq:iri) (object t))

5477

(gethash (spocq:iri-lexical-form predicate) (repository-entailment-cache repository)))

5478

(:method ((repository repository) (subject t) (predicate symbol) (object t))

5479

(gethash (symbol-uri-namestring predicate) (repository-entailment-cache repository)))

5480

5481

(:method ((repository repository) (subject t) (predicate t) (object t))

5482

nil))

5483

5484

#+(or)

5485

(defmethod resolve-repository-revision-id :after ((revision repository-revision))

5486

(update-repository-entailment-cache revision))

5487

5488

5489

#+(or)

5490

(defgeneric update-repository-entailment-cache (repository)

5491

(:method ((repository repository))

5492

(let ((cache (repository-entailment-cache repository))

5493

(graph (repository-entailment-graph repository)))

5494

(clrhash cache)

5495

(when graph

5496

(load-repository-entailment-cache (repository-id repository) cache :graph graph)))))

5497

5498

#+(or)

5499

(defgeneric load-repository-entailment-cache (repository cache &key graph)

5500

(:documentation "In RDFS++ terms (- domain/range) a given statement pattern should match:

5501

    - if it is an rdf:type pattern and the object is in rdfs:subClassOf relations, then any triple which specifies a subclass of the pattern object

5502

    - if the pattern predicate is in owl:sameAs relations, then any triple which specifies a member same set as the given

5503

    - if the pattern predicate is in rdfs:subPropertyOf relations, then any triple which specifies a sub-propeoperty of the given

5504

    - if the pattern predicate is in an owl:inverseOf relation, then in addition the the (?s p ?o) relation it should match also (?s ^p-inverse ?o)

5505

    - if the pattern predicate is rdf:type owl:TransitiveProperty, then any triple which is on a path which concludes with the given object

5506

5507

    this logic is accomplished by wrapping the elementary predicate with paths, in that order, to yield the effective predicate given the definitions. ")

5508

5509

(:method ((repository-id string) cache &rest args)

5510

(apply #'load-repository-entailment-cache (repository repository-id) cache args))

5511

5512

(:method ((repository repository) cache &key (graph |urn:dydra|:|default|))

5513

(labels ((get-cache-entry (predicate)

5514

;; either get the known entry or create and return the initial verb

5515

(gethash (iri-lexical-form predicate) cache))

5516

((setf get-cache-entry) (entry predicate)

5517

;; either get the known entry or create and return the initial verb

5518

(setf (gethash (iri-lexical-form predicate) cache) entry))

5519

(ensure-path-verb (predicate)

5520

(or (get-cache-entry predicate)

5521

(make-property-path-verb :iri predicate)))

5522

(cache-alternative-property-path (predicate alternatives)

5523

;;(print (list :alternative predicate alternatives))

5524

(setf (get-cache-entry predicate)

5525

(make-or-property-path :elements (cons (ensure-path-verb predicate)

5526

                                                             (loop for predicate in alternatives

5527

                                                               collect (ensure-path-verb predicate))))))

5528

(cache-inverse-property-path (predicate inverses)

5529

;;(print (list :inverse predicate inverses))

5530

(flet ((verb-is-inverse (verb)

5531

(and (inverted-property-path-p verb)

5532

                              (property-path-verb-p (inverted-property-path-element verb))

5533

                              (equalp predicate (property-path-verb-iri (inverted-property-path-element verb))))))

5534

(declare (dynamic-extent #'verb-is-inverse))

5535

(setf (get-cache-entry predicate)

5536

(make-or-property-path :elements (cons (ensure-path-verb predicate)

5537

                                                               (loop for predicate in inverses

5538

                                                                 for verb = (ensure-path-verb predicate)

5539

                                                                 ;; check for inverted original

5540

                                                                 collect (make-inverted-property-path

5541

                                                                          :element (if (or-property-path-p verb)

5542

                                                                                       (let* ((elements (property-path-elements verb))

5543

                                                                                              (unique-elements (remove-if #'verb-is-inverse elements)))

5544

                                                                                         (cond ((equal unique-elements elements)

5545

                                                                                                verb)

5546

                                                                                               ((rest unique-elements)

5547

                                                                                                (make-or-property-path :elements unique-elements))

5548

(t

5549

                                                                                                (first unique-elements))))

5550

                                                                                       verb))))))))

5551

5552

(cache-subclass-property-path (class)

5553

;;(print (list :subclass class))

5554

(setf (get-cache-entry class)

5555

(load-time-value

5556

(make-sequence-property-path

5557

:elements (list (make-property-path-verb :iri |rdf|:|type|)

5558

                                        (make-bounded-property-path :element (make-property-path-verb :iri |rdfs|:|subClassOf|)

5559

                                                                    :min 0 :max nil))))))

5560

(cache-same-as-property-paths (alternatives)

5561

;;(print (list :same-as alternatives))

5562

;; record sameAs relation as reciprocal alternative paths

5563

                (let ((alternative-path (make-or-property-path :elements (loop for predicate in alternatives

5564

                                                                           collect (ensure-path-verb predicate)))))

5565

(loop for predicate in alternatives

5566

do (setf (get-cache-entry predicate) alternative-path))))

5567

(cache-transitive-property-path (predicate)

5568

;;(print (list :transitive predicate))

5569

(setf (get-cache-entry predicate)

5570

                      (make-bounded-property-path :element (ensure-path-verb predicate) :min 0 :max nil))))

5571

(clrhash cache)

5572

(when graph

5573

(with-open-repository (repository)

5574

;; wrap predicates according to define rules:

5575

;; first, the sequence sameAs, subPropertyOf, inverseOf, TransitiveProperty

5576

;; then subClassOf (with a check, that there is no collision

5577

;;

5578

;; sameAs collects the closure and defines an alternative path as the replacement

5579

(let ((assertions ())

5580

(groups ()))

5581

(labels ((collect-group (predicate collected)

5582

                          (loop for other in (rest (assoc predicate assertions :test #'equalp))

5583

unless (member other collected :test #'equalp)

5584

do (progn (push other (rest collected))

5585

(setf collected (collect-group other collected)))

5586

finally (return collected)))

5587

(ensure-group (predicate)

5588

                          (unless (find-if #'(lambda (group) (member predicate group :test #'equalp)) groups)

5589

                            (let ((new-group (collect-group predicate (list predicate))))

5590

(if (rest new-group)

5591

(push new-group groups)

5592

                                  (log-warn "unary sameAs group: ~s." predicate))))))

5593

                 (do-statements ((nil predicate1 nil predicate2) *transaction* graph nil |owl|:|sameAs| nil)

5594

(let ((sames (assoc predicate1 assertions :test #'equalp)))

5595

(if sames

5596

(push predicate2 (rest sames))

5597

(push (list predicate1 predicate2) assertions)))

5598

(let ((sames (assoc predicate2 assertions :test #'equalp)))

5599

(if sames

5600

(push predicate1 (rest sames))

5601

(push (list predicate2 predicate1) assertions))))

5602

(loop for (predicate . nil) in assertions

5603

do (ensure-group predicate))

5604

(loop for group in groups

5605

do (cache-same-as-property-paths group))))

5606

             ;; subPropertyOf adds alternatives for the known subtypes, but in contrast to sameAs, the alternatives are distinct

5607

(let ((assertions ())

5608

(groups ()))

5609

(labels ((collect-group (predicate collected)

5610

                          (loop for other in (rest (assoc predicate assertions :test #'equalp))

5611

unless (member other collected :test #'equalp)

5612

do (progn (push other (rest collected))

5613

(setf collected (collect-group other collected)))

5614

finally (return collected)))

5615

(ensure-group (predicate)

5616

(let ((new-group (collect-group predicate (list predicate))))

5617

(if (rest new-group)

5618

(push new-group groups)

5619

                                (log-warn "unary subPropertyOf group: ~s." predicate)))))

5620

                 (do-statements ((nil sub-property nil property) *transaction* graph nil |rdfs|:|subPropertyOf| nil)

5621

(let ((subs (assoc property assertions :test #'equalp)))

5622

(if subs

5623

(push sub-property (rest subs))

5624

(push (list property sub-property) assertions))))

5625

(loop for (predicate . nil) in assertions

5626

do (ensure-group predicate))

5627

(loop for (predicate . subs) in groups

5628

do (cache-alternative-property-path predicate subs))))

5629

             ;; inverseOf add the immediate inverse(s) as alternatives, whereby the relation is reciprocal, but not transitive

5630

(let ((assertions ())

5631

(groups ()))

5632

(labels ((collect-group (predicate collected)

5633

                          (loop for other in (rest (assoc predicate assertions :test #'equalp))

5634

unless (member other collected :test #'equalp)

5635

do (progn (push other (rest collected))

5636

(setf collected (collect-group other collected)))

5637

finally (return collected)))

5638

(ensure-group (predicate)

5639

(let ((new-group (collect-group predicate (list predicate))))

5640

(if (rest new-group)

5641

(push new-group groups)

5642

                                (log-warn "unary inverseOf group: ~s." predicate)))))

5643

                 (do-statements ((nil predicate1 nil predicate2) *transaction* graph nil |owl|:|inverseOf| nil)

5644

;;(print (list predicate1 predicate2))

5645

(let ((inverses (assoc predicate1 assertions :test #'equalp)))

5646

(if inverses

5647

(push predicate2 (rest inverses))

5648

(push (list predicate1 predicate2) assertions)))

5649

(let ((inverses (assoc predicate2 assertions :test #'equalp)))

5650

(if inverses

5651

(push predicate1 (rest inverses))

5652

(push (list predicate2 predicate1) assertions))))

5653

(loop for (predicate . nil) in assertions

5654

do (ensure-group predicate))

5655

(loop for (predicate . inverses) in groups

5656

do (cache-inverse-property-path predicate inverses))))

5657

;; transitive properties

5658

             (do-statements ((nil predicate nil nil) *transaction* graph nil |rdf|:|type| |owl|:|TransitiveProperty|)

5659

(cache-transitive-property-path predicate))

5660

5661

;; finally indicate the subtype chain property for all abstract classes,

5662

;; but preclude existing predicate definitions

5663

(do-statements ((nil nil nil class) *transaction* graph nil |rdfs|:|subClassOf| nil)

5664

(when (iri-p class) ; skip blank nodes from restrictions

5665

(let ((entry (get-cache-entry class)))

5666

(when entry

5667

(assert (sequence-property-path-p entry) ()

5668

                           "Ambiguous definition present for class: ~s: ~s" class entry))

5669

(cache-subclass-property-path class))))))

5670

cache)))

5671

5672

(defgeneric repository-resource-view-name (repository resource)

5673

(:method ((repository repository) (resource-identifier string))

5674

(multiple-value-bind (matched results)

5675

(cl-ppcre:scan-to-strings (load-time-value

5676

                                                     (cl-ppcre:create-scanner

5677

                                                      `(:sequence :start-anchor

5678

                                                                  (:greedy-repetition 0 1

5679

                                                                                      (:sequence (:alternation "http" "https")

5680

                                                                                                 "://"

5681

                                                                                                 (:greedy-repetition 0 nil (:inverted-char-class #\/))

5682

                                                                                                 "/"))

5683

                                                                  (:greedy-repetition 0 nil (:inverted-char-class #\/))

5684

"/"

5685

                                                                  (:greedy-repetition 0 nil (:inverted-char-class #\/))

5686

"/"

5687

                                                                  (:register (:greedy-repetition 0 nil (:inverted-char-class #\?)))

5688

                                                                  (:greedy-repetition 0 nil :everything)

5689

                                                                  :end-anchor)))

5690

                                                    resource-identifier)

5691

(when matched (aref results 0))))

5692

5693

(:method ((repository service-repository) (resource-identifier string))

5694

;; given a service repository, the view name is everythis after the authority

5695

(multiple-value-bind (matched results)

5696

(cl-ppcre:scan-to-strings (load-time-value

5697

                                                     (cl-ppcre:create-scanner

5698

                                                      `(:sequence :start-anchor

5699

                                                                  (:greedy-repetition 0 1

5700

                                                                                      (:sequence (:alternation "http" "https")

5701

                                                                                                 "://"

5702

                                                                                                 (:greedy-repetition 0 nil (:inverted-char-class #\/))

5703

                                                                                                 "/"))                                                                 (:register (:greedy-repetition 0 nil :everything))

5704

                                                                  :end-anchor)))

5705

                                                    resource-identifier)

5706

(when matched (aref results 0)))))

5707

5708

#+(or)

5709

(loop for resource in '("" "http://" "jhacker/foaf/view"

5710

                         "http://dydra.com/jhacker/foaf/view" "jhacker/foaf/view-with/more.parts/here"

5711

"http://localhost/jhacker/foaf/view?revisionid=xxxx")

5712

collect (repository-resource-view-name (repository "test/test") resource))

5713

5714

(defmethod initialize-instance ((instance rdfcache-repository) &rest initargs

5715

&key (storage-class nil sd-s))

5716

(let ((sd (find 'storage-class (class-slots (class-of instance)) :key #'c2mop:slot-definition-name)))

5717

(case (c2mop:slot-definition-allocation sd)

5718

(:class (when sd-s

5719

(assert (eq storage-class (repository-storage-class instance)) ()

5720

                         "initialize-instance: invalid storage class: ~s: ~s" (type-of instance) storage-class)))

5721

(:instance (unless sd-s

5722

                    (setf initargs (list* :storage-class (rlmdb:get-metadata-storage-class (repository-id instance))

5723

initargs)))))

5724

(apply #'call-next-method instance initargs)))

5725

5726

;;; resource authorization

5727

5728

(defgeneric repository-public-p (repository)

5729

(:method ((resource authorized-resource))

5730

(anonymous-authorization-p (resource-authorization-list resource))))

5731

5732

(defun create-location-authorization-scanner (patterns)

5733

"Compile a list of location patterns into a single regular expression scanner."

5734

5735

(typecase patterns

5736

(string (cl-ppcre:create-scanner patterns))

5737

(null nil)

5738

(cons (if (rest patterns)

5739

(cl-ppcre:create-scanner `(:alternation ,@(mapcar #'cl-ppcre:parse-string patterns)))

5740

(cl-ppcre:create-scanner (first patterns))))

5741

(t

5742

(error "Invalid authorization pattern list: ~s." patterns))))

5743

5744

(defun print-repository-authorization-lists (&optional (stream *standard-output*))

5745

(print (repository-authorization-lists) stream))

5746

5747

(defun repository-authorization-lists ()

5748

(loop for v being each hash-value of *repository-authorization-lists*

5749

collect v))

5750

5751

(defun clear-repository-authorization-lists ()

5752

(clrhash *repository-authorization-lists*))

5753

5754

(defgeneric find-repository-authorization-list (id)

5755

(:method ((id spocq:iri))

5756

(find-repository-authorization-list (spocq:iri-lexical-form id)))

5757

(:method ((id string))

5758

(gethash id *repository-authorization-lists*)))

5759

5760

(defgeneric (setf find-repository-authorization-list) (authorization-list id)

5761

(:method ((a-list t) (id spocq:iri))

5762

(setf (find-repository-authorization-list (spocq:iri-lexical-form id)) a-list))

5763

(:method ((a-list authorization-list) (id string))

5764

(setf (gethash id *repository-authorization-lists*) a-list))

5765

(:method ((control-list list) (id t))

5766

(setf (gethash id *repository-authorization-lists*) control-list)))

5767

5768

(defun list-all-repositories ()

5769

(with-open-program (stream "/opt/dydra/bin/dydra-admin" '("list-repositories"))

5770

(loop for repo = (read-line stream nil nil)

5771

until (null repo)

5772

collect repo)))

5773

;;; (list-all-repositories)

5774

5775

5776

;;;

5777

;;; request-processor

5778

5779

(defgeneric request-processor-continue-p (processor)

5780

(:method ((processor request-processor))

5781

t))

5782

5783

;;;

5784

;;; revision

5785

5786

(defmethod initialize-instance ((instance transaction) &rest initargs &key task (task-id (task-id task)))

5787

(declare (dynamic-extent initargs))

5788

#+(or)

5789

;; as a note that this is wrong.

5790

;; it must be possible to create a "lightweight" transaction, without a repository

5791

   ;; instance, as to construct the latter can require reading its metadata, which requires a transaction.

5792

;; the revision, on the other hand is needed as its id is the basis of the transaction, but its

5793

;; construction cannot depend on the reference

5794

(apply #'call-next-method instance

5795

:revision (or revision

5796

(make-instance revision-class :reference (or repository

5797

                                                                     (if repository-id

5798

                                                                       (repository repository-id)

5799

                                                                       (error "either repository or repository-id is required.")))

5800

:revision-id (cond (revision-id)

5801

                                                          (repository-id (rdfcache::resolve-repository repository-id))

5802

                                                          (repository (rdfcache::resolve-repository (repository-id repository)))

5803

                                                          (t (error "either revision-id, repository, or repository-id is required.")))))

5804

initargs)

5805

5806

(apply #'call-next-method instance

5807

:task-id task-id

5808

initargs))

5809

5810

(defgeneric repository-list-revision-metadata (repository)

5811

(:method ((repository repository))

5812

(repository-list-revision-metadata (repository-id repository)))

5813

(:method ((repository-id string))

5814

(loop with process = (sb-ext:run-program (namestring (admin-executable-pathname))

5815

                                              (list "list-revisions" "-v" repository-id)

5816

                                              :input nil :output :stream

5817

                                              ;; otherwise it blocks for large lists

5818

:wait nil)

5819

for line = (read-line (sb-ext:process-output process) nil)

5820

until (null line)

5821

for (nil uuid unix-time) = (split-string line #(#\space #\tab))

5822

collect (list uuid (parse-integer unix-time))

5823

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

5824

5825

(defgeneric repository-list-revision-ids (repository-id)

5826

(:method ((repository-id string))

5827

(repository-list-revision-ids (repository repository-id)))

5828

5829

(:method ((repository repository))

5830

(let* ((repository-id (repository-id repository))

5831

(process (sb-ext:run-program (namestring (admin-executable-pathname))

5832

                                         (list "list-revisions" repository-id)

5833

:input nil :output :stream

5834

                                         ;; otherwise it blocks for large lists

5835

:wait nil)))

5836

(when process

5837

(unwind-protect (loop with input = (sb-ext:process-output process)

5838

for uuid = (read-line input nil)

5839

until (null uuid)

5840

collect uuid

5841

finally (close input))

5842

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

5843

5844

(defgeneric is-instant-revision (revision)

5845

(:method ((object t))

5846

nil)

5847

(:method ((revision repository-revision))

5848

(member :instant (repository-revision-mode revision))))

5849

5850

(defgeneric is-interval-revision (revision)

5851

(:method ((object t))

5852

nil)

5853

(:method ((revision repository-revision))

5854

(member :interval (repository-revision-mode revision))))

5855

5856

(defgeneric is-prospective-revision (revision)

5857

(:method ((object t))

5858

nil)

5859

(:method ((revision repository-revision))

5860

(member :prospective (repository-revision-mode revision))))

5861

5862

(defgeneric is-retrospective-revision (revision)

5863

(:method ((object t))

5864

nil)

5865

(:method ((revision repository-revision))

5866

(member :retrospective (repository-revision-mode revision))))

5867

5868

5869

(defgeneric repository-revision-bounds (repository)

5870

(:documentation "Return the :tail and :head data-time values iff the repository is revisioned.")

5871

(:method ((repository-id string))

5872

(repository-revision-bounds (repository repository-id)))

5873

(:method ((repository repository))

5874

nil))

5875

5876

;;; (repository-list-revision-metadata "jhacker/foaf")

5877

5878

5879

(defgeneric repository-revision-start-date-time (revision)

5880

(:method ((revision repository-revision))

5881

(or (repository-revision-get-start-date-time revision)

5882

(let* ((id (repository-revision-id revision))

5883

                (metadata (repository-list-revision-metadata (repository-revision-reference revision))))

5884

(when (setf metadata (member id (reverse metadata) :test #'equal :key #'first))

5885

(when (second metadata)

5886

(setf (slot-value revision 'end-date-time)

5887

(timeline-location-date-time (second (second metadata)))))

5888

(setf (slot-value revision 'start-date-time)

5889

(timeline-location-date-time (second (first metadata)))))))))

5890

5891

;;; (repository-revision-start-date-time (repository-revision "HEAD" :reference "openrdf-sesame/mem-rdf"))

5892

;;; (repository-revision-end-date-time (repository-revision "HEAD" :reference "openrdf-sesame/mem-rdf"))

5893

;;; (repository-revision-start-date-time (repository-revision "HEAD~1" :reference "openrdf-sesame/mem-rdf"))

5894

;;; (repository-revision-end-date-time (repository-revision "HEAD~1" :reference "openrdf-sesame/mem-rdf"))

5895

5896

5897

(defgeneric revision-signature (transaction)

5898

(:method ((transaction transaction))

5899

(revision-signature (transaction-revision transaction)))

5900

(:method ((revision repository-revision))

5901

(or (get-revision-signature revision)

5902

(setf-revision-signature (compute-revision-signature revision) revision))))

5903

5904

(defparameter *revision-signature-type* :sha256

5905

"The default digest type when computing revision signatures")

5906

5907

(defgeneric compute-revision-signature (revision &key digest-type)

5908

(:documentation "Compute a hash signature from the given revision.

5909

:digest-type : specify the digest type; defaults to *revision-signature-type*")

5910

(:method ((transaction t) &key digest-type)

5911

(declare (ignore digest-type))

5912

nil))

5913

5914

5915

;;;

5916

;;; task

5917

5918

(defgeneric task-effective-request-operation (task nominal-operation)

5919

(:documentation "Given a task instance and the nominal operation derived from the

5920

query text, compute the effective operation given other contributing factors,

5921

such as the response content type.")

5922

5923

(:method ((task task) (operation (eql :update)))

5924

operation)

5925

(:method ((task task) (operation t))

5926

(media-type-effective-request-operation (task-response-content-type task) operation)))

5927

5928

(defgeneric media-type-effective-request-operation (task nominal-operation)

5929

(:documentation "Given a media type and the nominal request operation,

5930

determine the actual operation. THis may divert processing from simply executing the

5931

query and returning the results to returning the parsed algebra expression or

5932

the executed query plan.")

5933

5934

(:method ((media-type t) (operation t))

5935

operation)

5936

5937

(:method ((media-type mime:*/vnd.dydra.sparql-query-algebra) (operation t))

5938

:algebra)

5939

5940

(:method ((media-type mime:*/vnd.dydra.sparql-query-plan) (operation t))

5941

:plan)

5942

5943

(:method ((media-type mime:*/vnd.dydra.sparql-results-trace) (operation t))

5944

:trace)

5945

)

5946

5947

5948

;;;

5949

;;; authority

5950

5951

(defgeneric authority (object &rest args)

5952

(:documentation "Compute the respective authority instance for its identifier.

5953

Retrieve propertie - omong other its authentication information")

5954

(:method ((authority authority) &key)

5955

authority)

5956

(:method ((id string) &rest args)

5957

(multiple-value-bind (authority name-seen) (get-registry id *users*)

5958

(cond (name-seen

5959

authority)

5960

(t

5961

(setf (get-registry id *users*)

5962

(let ((properties (retrieve-authority-properties id)))

5963

(when properties

5964

(apply #'make-instance 'authority

5965

:identifier (compute-user-identifier id)

5966

(append args properties))))))))))

5967

5968

(defgeneric retrieve-authority-properties (name)

5969

(:documentation "Given an authority identifier, retrieve its properties,

5970

among them the authentication token and/pr password.

5971

Decrypt these if present.

5972

nb. each authority is placed in its own graph,")

5973

(:method ((name string))

5974

(retrieve-authority-properties (compute-user-identifier name)))

5975

(:method ((id spocq:iri))

5976

(when *system-repository-id* ;; disable of not connected

5977

(let ((sparql (sublis (acons '?::|s| id nil)

5978

                             (parse-sparql "select ?title ?password ?authToken where {

5979

graph ?s {?s <http://purl.org/dc/elements/1.1/title> ?title .

5980

optional { ?s <urn:dydra:encryptedPassword> ?password . }

5981

optional { ?s <urn:dydra:accessToken> ?authToken . }}}"))))

5982

(let ((results (run-sparql-internal sparql :repository-id *system-repository-id*

5983

:agent (system-agent)

5984

;;:dynamic-bindings `((?::|s|) ,id)

5985

)))

5986

(when results

5987

(destructuring-bind ((name password token) . rest) results

5988

(cond (rest

5989

(log-warn "retrieve-authority-properties: ambiguous result: ~a" id)

5990

nil)

5991

(t

5992

`(:name ,name

5993

                              :password ,(when (stringp password) (decrypt-character-data password))

5994

                              :token ,(when (stringp token) (decrypt-character-data token))))))))))))

5995

5996

5997

(defgeneric store-authority-properties (id &key name password token)

5998

(:method ((id string) &rest args &key (name id) password token)

5999

(declare (ignore password token))

6000

(apply #'store-authority-properties (compute-user-identifier id) :name name args))

6001

(:method ((id spocq:iri) &key password token name)

6002

(when password (setf password (encrypt-character-data password)))

6003

(when token (setf token (encrypt-character-data token)))

6004

(let ((update (parse-sparql "delete where { graph ?s {?s ?p ?o } }; insert data {}"))

6005

(data (parse-sparql (concatenate 'string "select * where

6006

{ graph ?s {?s <http://purl.org/dc/elements/1.1/title> ?title . "

6007

                                 (when password "?s <urn:dydra:encryptedPassword> ?password . ")

6008

                                 (when token "?s <urn:dydra:accessToken> ?token . ")

6009

"} }"))))

6010

(setf (second update) (sublis `((?::|s| . ,id)) (second update))

6011

(second (third update))

6012

6013

                                                (?::|password| . ,password) (?::|title| . ,name))

6014

                                              (rest (third (second data)))))))

6015

       (let ((result (run-sparql-internal update :repository-id *system-repository-id* :agent (system-agent))))

6016

(assert (equal result '(())) () "Error creating authority"))

6017

t)))

6018

6019

;;;

6020

;;; user

6021

6022

#+(or) ;; subsumed by identifier object initialization

6023

(defmethod initialize-instance :after ((instance user) &key)

6024

(unless (slot-boundp instance 'identifier)

6025

(setf-instance-identifier (compute-instance-identifier instance) instance)))

6026

6027

(defgeneric user (object &rest args)

6028

(:method ((user user) &key)

6029

user)

6030

(:method ((name string) &rest args)

6031

(or (get-registry name *users*)

6032

(setf (get-registry name *users*)

6033

(apply #'make-instance 'user :name name args)))))

6034

6035

(defun users ()

6036

(loop for user being each hash-value of *users*

6037

using (hash-key id)

6038

when (stringp id)

6039

collect user))

6040

6041

(defun print-users (&optional (stream *standard-output*))

6042

(print (users) stream))

6043

6044

(defun user-identities ()

6045

(loop for user being each hash-value of *users*

6046

using (hash-key id)

6047

collect (cons id user)))

6048

6049

(defun print-user-identities (&optional (stream *standard-output*))

6050

(print (user-identities) stream))

6051

6052

;;;

6053

;;; boxed terms

6054

6055

(defgeneric compute-literal-value (literal)

6056

(:method ((literal spocq:boolean))

6057

(ebv literal))

6058

(:method ((literal spocq:decimal))

6059

(spocq.e:decimal (spocq:literal-lexical-form literal)))

6060

(:method ((literal spocq:double))

6061

(spocq.e:double (spocq:literal-lexical-form literal)))

6062

(:method ((literal spocq:float))

6063

(spocq.e:float (spocq:literal-lexical-form literal)))

6064

(:method ((literal spocq:integer))

6065

(spocq.e:integer (spocq:literal-lexical-form literal)))

6066

(:method ((literal spocq:string))

6067

(spocq:literal-lexical-form literal))

6068

(:method ((literal spocq:compound-typed-literal))

6069

literal))

6070

6071

6072

(defgeneric literal-value (literal)

6073

(:method ((literal spocq:plain-literal))

6074

(spocq:literal-lexical-form literal))

6075

(:method ((literal spocq:compound-typed-literal))

6076

literal)

6077

(:method ((literal spocq:atomic-typed-literal))

6078

(or (spocq:atomic-typed-literal-value literal)

6079

(setf (spocq:atomic-typed-literal-value literal)

6080

(compute-literal-value literal)))))

6081

6082

6083

(defgeneric term-lexical-form (term)

6084

(:method ((term spocq:iri)) (spocq:iri-lexical-form term))

6085

(:method ((term symbol)) (symbol-uri-namestring term))

6086

(:method ((term string)) term)

6087

(:method ((term spocq:atomic-typed-literal))

6088

(or (spocq:literal-lexical-form term)

6089

(setf (spocq:literal-lexical-form term)

6090

(spocq.e:string (spocq:atomic-typed-literal-value term)))))

6091

(:method ((term spocq:date))

6092

(|-yyyy-MM-dd(ZZZZ)?| term)

6093

#+(or)

6094

(or (spocq:literal-lexical-form term)

6095

(setf (spocq:literal-lexical-form term)

6096

(cond ((and (zerop (spocq:date-hour term)) (zerop (spocq:date-minute term)))

6097

(|-yyyy-MM-dd| term nil))

6098

(t

6099

(|-yyyy-MM-ddZZZZ| term nil))))))

6100

(:method ((term spocq:date-time))

6101

(|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| term)

6102

#+(or)

6103

(setf (spocq:literal-lexical-form term)

6104

(let ((fraction (spocq:date-time-fraction term)))

6105

(if fraction

6106

(let* ((fraction-string (format nil "~f" fraction))

6107

(date-string (|-yyyy-MM-ddTHH:mm:ssZZZZ| term nil))

6108

(dot (position #\. fraction-string))

6109

(z (position #\z date-string :test #'char-equal)))

6110

                   (concatenate 'string (subseq date-string 0 z) (subseq fraction-string dot) (subseq date-string z)))

6111

(|-yyyy-MM-ddTHH:mm:ssZZZZ| term nil)))))

6112

(:method ((term spocq:day-time-duration))

6113

(|PnDTnHnMnS| term))

6114

(:method ((term spocq:duration))

6115

(|PnYnMnDTnHnMnS| term))

6116

(:method ((term spocq:g-day))

6117

(|---dd(ZZZZZZ)?| term))

6118

(:method ((term spocq:g-month))

6119

(|--MM(ZZZZZZ)?| term))

6120

(:method ((term spocq:g-month-day))

6121

(|--MM-dd(ZZZZZZ)?| term))

6122

(:method ((term spocq:g-year))

6123

(|YYYY(ZZZZZZ)?| term))

6124

(:method ((term spocq:g-year-month))

6125

(|YYYY-MM(ZZZZZZ)?| term))

6126

(:method ((term spocq:time))

6127

(|HH:mm:ss(ZZZZ)?| term)

6128

#+(or)

6129

(or (spocq:literal-lexical-form term)

6130

(setf (spocq:literal-lexical-form term)

6131

(let ((fraction (spocq:time-fraction term)))

6132

(if fraction

6133

(let* ((fraction-string (format nil "~f" fraction))

6134

(time-string (|HH:mm:ssZZZZ| term nil))

6135

(dot (position #\. fraction-string))

6136

(z (position #\z time-string :test #'char-equal)))

6137

                     (concatenate 'string (subseq time-string 0 z) (subseq fraction-string dot) (subseq time-string z)))

6138

(|-yyyy-MM-ddTHH:mm:ssZZZZ| term nil))))))

6139

(:method ((term spocq:year-month-duration))

6140

(|PnYnM| term)))

6141

6142

6143

(defgeneric iri-lexical-form (iri)

6144

(:method ((iri string))

6145

iri)

6146

(:method ((iri spocq:iri))

6147

(spocq:iri-lexical-form iri))

6148

(:method ((iri symbol))

6149

(symbol-uri-namestring iri))

6150

(:method ((uri puri:uri))

6151

(with-output-to-string (stream) (puri:render-uri uri stream))))

6152

6153

(defmethod puri:uri ((iri spocq:iri) &key &allow-other-keys)

6154

(puri:uri (spocq:iri-lexical-form iri)))

6155

6156

(defmethod puri:uri ((iri symbol) &rest args)

6157

"Extend the puri symbol method to recognize some as uri themselves"

6158

(declare (dynamic-extent args))

6159

(cond ((keywordp iri)

6160

(apply #'make-instance puri::*class.uri* iri args))

6161

((iri-p iri)

6162

(puri:uri (symbol-uri-namestring iri)))

6163

(t

6164

(puri:uri (apply #'make-instance iri args)))))

6165

6166

(defgeneric iri-parsed-path (iri)

6167

(:method ((iri puri:uri))

6168

(puri:uri-parsed-path iri))

6169

(:method ((iri string))

6170

(puri:uri-parsed-path (puri:uri iri)))

6171

(:method ((iri spocq:iri))

6172

(puri:uri-parsed-path (puri:uri (spocq:iri-lexical-form iri))))

6173

(:method ((iri symbol))

6174

(puri:uri-parsed-path (puri:uri iri))))

6175

6176

6177

(defun literal-datatype-uri (literal)

6178

(spocq.e:data-type literal))

6179

6180

6181

6182

(defmethod print-object ((object spocq:date) (stream t))

6183

(if *print-escape*

6184

(format stream "#@~s" (multiple-value-bind (form error)

6185

                                                (ignore-errors (term-lexical-form object))

6186

                             (or form (format nil "<invalid date: ~a>" (type-of error)))))

6187

(call-next-method)))

6188

6189

(defmethod print-object ((object spocq:date-time) (stream t))

6190

(if *print-escape*

6191

(format stream "#@~s" (multiple-value-bind (form error)

6192

                                                (ignore-errors (term-lexical-form object))

6193

                             (or form (format nil "<invalid date-time: ~a>" (type-of error)))))

6194

(call-next-method)))

6195

6196

(defmethod print-object ((object spocq:time) (stream t))

6197

(if *print-escape*

6198

(format stream "#@~s" (multiple-value-bind (form error)

6199

                                                 (ignore-errors (term-lexical-form object))

6200

                              (or form (format nil "<invalid time: ~a>" (type-of error)))))

6201

(call-next-method)))

6202

6203

(defun read-date-time (stream char arg)

6204

(declare (ignore char arg))

6205

(let ((lexical-form (read stream t nil t)))

6206

(cond (*read-suppress*

6207

(values))

6208

(t

6209

(assert (and (stringp lexical-form) (plusp (length lexical-form))) ()

6210

"Invalid date-time form: ~s." lexical-form)

6211

(or (ignore-errors (|-yyyy-MM-ddTHH:mm:ss(ZZZZZZ)?| lexical-form))

6212

(ignore-errors (|HH:mm:ss(ZZZZ)?| lexical-form))

6213

(ignore-errors (|-yyyy-MM-dd(ZZZZ)?| lexical-form))

6214

(error "Invalid date-time form: ~s." lexical-form))))))

6215

6216

(set-packaged-dispatch-macro-character #\# #\@ 'read-date-time)

6217

6218

6219

6220

;;; form predicates

6221

;;; nb. here, as it requires the query class definition

6222

6223

(macrolet ((def-form-p (name)

6224

(let ((spocq-op (or (find-symbol (string-downcase name) :spocq.a)

6225

(error "Invalid algebra operator: ~s." name)))

6226

(name (cons-symbol :spocq.i (string-upcase name) :-form-p)))

6227

`(progn

6228

(deftype ,spocq-op () '(satisfies ,name))

6229

(defgeneric ,name (object)

6230

                     (:documentation ,(format nil "True iff the expression operator is '~a'" spocq-op))

6231

(:method ((object t)) nil)

6232

(:method ((object cons)) (eq (first object) ',spocq-op))

6233

(:method ((object query)) (,name (query-sse-expression object))))))))

6234

(def-form-p &&)

6235

(def-form-p and)

6236

(def-form-p ask)

6237

(def-form-p bgp)

6238

(def-form-p bind)

6239

(def-form-p bindings)

6240

(def-form-p construct)

6241

(def-form-p declare)

6242

(def-form-p describe)

6243

(def-form-p distinct)

6244

(def-form-p exprlist)

6245

(def-form-p extend)

6246

(def-form-p filter)

6247

(def-form-p graph)

6248

(def-form-p join)

6249

(def-form-p leftjoin)

6250

(def-form-p minus)

6251

(def-form-p modify)

6252

(def-form-p null)

6253

(def-form-p not)

6254

(def-form-p or)

6255

(def-form-p project)

6256

(def-form-p quad)

6257

(def-form-p revision)

6258

(def-form-p select)

6259

(def-form-p service)

6260

(def-form-p servicejoin)

6261

(def-form-p slice)

6262

(def-form-p sum)

6263

(def-form-p table)

6264

(def-form-p triple)

6265

(def-form-p union)

6266

(def-form-p update))

6267

6268

6269

(defgeneric describe-slot-definition (class slot-name)

6270

(:method ((name symbol) slot-name)

6271

(describe-slot-definition (find-class name) slot-name))

6272

(:method ((class standard-class) (slot-name symbol))

6273

(list (class-name class)

6274

           (let ((definition (find slot-name (class-direct-slots class) :key #'c2mop:slot-definition-name)))

6275

(when definition

6276

(list :initform (c2mop:slot-definition-initform definition)

6277

:allocation (c2mop:slot-definition-allocation definition))))

6278

(loop for sub in (class-direct-subclasses class)

6279

collect (describe-slot-definition sub slot-name))))

6280

(:method ((class class) (slot-name t))

6281

(class-name class)))

6282

6283

6284

;;; (describe-slot-definition 'repository 'storage-class)

6285

6286

6287

6288

6289

6290

#|

6291

6292

(defgeneric boxed-+ (arg1 arg2)

6293

(:method ((arg1 number) (arg2 number))

6294

(+ arg1 arg2))

6295

(:method ((arg1 spocq:integer) (arg2 spocq:integer))

6296

(let ((value (+ (literal-value arg1) (literal-value arg2))))

6297

(make-integer-literal :cached-value value :string (prin1-to-string value)))))

6298

6299

(defun do-generic (arg1 arg2 &key (count 1000000))

6300

(let ((v nil))

6301

(dotimes (i count v) (setf v (boxed-+ arg1 arg2)))

6302

v))

6303

6304

(defun do-native (arg1 arg2 &key (count 1000000))

6305

(let ((v nil))

6306

(dotimes (i count v) (setf v (+ arg1 arg2)))

6307

v))

6308

6309

;; (time (do-generic 100 100))

6310

;; (time (do-native 100 100))

6311

;; (time (do-generic (spocq:make-integer :lexical-form "100") (spocq:make-integer :lexical-form "100")))

6312

6313

6314

6315

|#

6316

6317