Coverage report: /development/source/library/org/datagraph/spocq-shard/src/store/repository.lisp

Kind	Covered	All	%
expression	681	1756	38.8
branch	22	64	34.4

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 "This file defines abstract repository definitions and operators

6

for the 'org.datagraph.spocq' RDF engine."

7

8

(copyright

9

10

11

(long-description

12

"A repository object serves as a proxy for the content of a remote store.

13

Each concrete class implements operators to

14

- count statements in the repository

15

- count statements which match a give pattern.

16

"))

17

18

;;; generic graph operations

19

;;; the base method uses the rdfcache library, which allows various arguments as

20

;;; graph designators. all are transformed into strings, whereby if a term number is passed,

21

;;; the ndk perfomred a locked term fetch. this interface circumvents that.

22

23

;;;

24

;;; repository creation

25

26

(defmethod initialize-repository-metadata ((repository repository))

27

(flet ((filter-field (field)

28

(loop for stmt in field

29

if (member nil stmt)

30

do (log-warn "initialize-repository-metadata: incomplete statement: ~s" stmt)

31

else collect stmt)))

32

(let* ((account (repository-account repository))

33

(account-repository-name (instance-repository-id account))

34

(account-identifier (account-identifier account))

35

(repository-identifier (repository-identifier repository))

36

(account-name (account-name account))

37

(repository-name (repository-name repository)))

38

(destructuring-bind (&key system account)

39

(compute-initial-repository-metadata repository)

40

(with-open-transaction (account-repository-name :normal-disposition :commit :read-only-p nil)

41

(repository-clear-graph *transaction* repository-identifier :if-does-not-exist nil)

42

(repository-insert-field *transaction* (filter-field account)))

43

(with-open-transaction (*system-repository-id* :normal-disposition :commit :read-only-p nil)

44

;; must delete explicitly as it is not in its own graph in the global repository

45

           (let ((existing-field (repository-match-field *transaction* account-identifier repository-identifier '?::p '?::o)))

46

(when existing-field

47

(repository-delete-field *transaction* existing-field)))

48

(repository-insert-field *transaction* (filter-field system)))

49

         (log-notice "initialize-repository-metadata: system repositories initialized: ~a ~a" repository (agent))

50

;; record initial mysql metadata, but do not modify it

51

(unless (spocq.i::read-sql-repository :name repository-name

52

                                               :account-name account-name)

53

(let* ((sql-account (or (read-sql-account :name account-name)

54

                                   (error "initialize-repository-metadata: no account record: ~a" repository)))

55

(sql-repository (make-sql-repository :name repository-name

56

                                                       :account-id (sql-account-id sql-account)

57

                                                       :account sql-account

58

                                                       :uuid (repository-uuid repository))))

59

(spocq.i::write-sql-repository sql-repository)

60

             (log-notice "initialize-repository-metadata: mysql initialized: ~a ~a" repository (agent))))))))

61

;;; new

62

 ;;; (spocq.i::write-sql-repository (make-sql-repository :name "test2" :account-id (sql-account-id (read-sql-account :name "james")) :uuid (repository-uuid "james/test2")))

63

;;; modified

64

;;; (spocq.i::write-sql-repository (spocq.i::read-sql-repository :name "test2" :account-name "james"))

65

66

(defgeneric delete-repository-metadata (repository)

67

(:documentation "Clear the graph in the account store and delete all statements with the respective

68

subject in the system store")

69

70

(:method ((repository repository))

71

(let ((account-repository-id (instance-repository-id (repository-account repository)))

72

(account-identifier (account-identifier (repository-account repository)))

73

(repository-identifier (repository-identifier repository)))

74

(with-open-transaction (account-repository-id :normal-disposition :commit :read-only-p nil)

75

(repository-clear-graph *transaction* repository-identifier :if-does-not-exist nil))

76

#+(or) ;; do not run a query

77

(run-sparql-internal `(spocq.a:|update|

78

(spocq.a:|deleteWhere|

79

                                                 ((spocq.a:|graph| ,account-identifier

80

                                                           ((spocq.a:|triple| ,repository-identifier ?::|p| ?::|o|))))))

81

:repository-id *system-repository-id*

82

:agent (system-agent))

83

(with-open-transaction (*system-repository-id* :normal-disposition :commit :read-only-p nil)

84

         ;; must delete explicitly as repository data is not in its own graph in the global repository

85

         (let ((existing-field (repository-match-field *transaction* account-identifier repository-identifier '?::p '?::o)))

86

(when existing-field

87

(repository-delete-field *transaction* existing-field)))))))

88

89

;;; (delete-repository-metadata (repository "openrdf-sesame/deleteme"))

90

;; abstracted to file-ssyten-repository

91

(undefmethod delete-repository-storage ((repository rdfcache-repository))

92

"Delete the persistent entity which corresponds to the repository instance."

93

(let ((id (repository-id repository)))

94

(cli-delete-repository id)

95

(delete-repository-metadata repository)

96

repository))

97

98

(defgeneric cli-delete-repository (repository)

99

(:method ((id string))

100

(let ((process (run-program (admin-executable-pathname) (list "drop-repository" id) :wait t)))

101

(if process

102

(run-program-close process)

103

(error "Failed to delete repository: ~s." id))

104

t))

105

(:method ((repository repository))

106

(cli-delete-repository (repository-id repository))))

107

108

;;; (delete-repository (repository "openrdf-sesame/deleteme"))

109

110

111

(defun cli-probe-repository (id)

112

(let ((process (run-program (admin-executable-pathname) (list "resolve-revision" id) :wait t)))

113

(when process

114

(run-program-close process)

115

t)))

116

117

(defun sparql-graph-argument (term)

118

(cond ((= term rlmdb:*wildcard-term-number*)

119

(cffi:null-pointer))

120

((= term rlmdb:*default-context-number*)

121

(rdfcache::%default-context-pointer))

122

(t

123

(rlmdb:term-iri-namestring term))))

124

125

(defgeneric sparql-add (transaction-pointer graph1-uri graph2-uri &optional silent)

126

(:method (transaction (graph1-uri integer) graph2-uri &optional silent)

127

(sparql-add transaction (sparql-graph-argument graph1-uri) graph2-uri silent))

128

(:method (transaction graph1-uri (graph2-uri integer) &optional silent)

129

(sparql-add transaction graph1-uri (sparql-graph-argument graph2-uri) silent)))

130

131

(defgeneric sparql-clear (transaction-pointer graph-uri &optional silent)

132

(:method (transaction (graph-uri integer) &optional silent)

133

(sparql-clear transaction (sparql-graph-argument graph-uri) silent)))

134

135

(defgeneric sparql-copy (transaction-pointer graph1-uri graph2-uri &optional silent)

136

(:method (transaction (graph1-uri integer) graph2-uri &optional silent)

137

(sparql-copy transaction (sparql-graph-argument graph1-uri) graph2-uri silent))

138

(:method (transaction graph1-uri (graph2-uri integer) &optional silent)

139

(sparql-copy transaction graph1-uri (sparql-graph-argument graph2-uri) silent)))

140

141

(defgeneric sparql-create (transaction-pointer graph-uri &optional silent)

142

(:method (transaction (graph-uri integer) &optional silent)

143

(sparql-create transaction (sparql-graph-argument graph-uri) silent)))

144

145

(defgeneric sparql-drop (transaction-pointer graph-uri &optional silent)

146

(:method (transaction (graph-uri integer) &optional silent)

147

(sparql-drop transaction (sparql-graph-argument graph-uri) silent)))

148

149

(defgeneric sparql-load (transaction-pointer graph-uri from-url &optional silent)

150

(:method (transaction (graph-uri integer) from-url &optional silent)

151

(sparql-load transaction (sparql-graph-argument graph-uri) from-url silent))

152

(:method (transaction graph-uri (from-url integer) &optional silent)

153

(sparql-load transaction graph-uri (sparql-graph-argument from-url) silent)))

154

155

(defgeneric sparql-move (transaction-pointer graph1-uri graph2-uri &optional silent)

156

(:method (transaction (graph1-uri integer) graph2-uri &optional silent)

157

(sparql-move transaction (sparql-graph-argument graph1-uri) graph2-uri silent))

158

(:method (transaction graph1-uri (graph2-uri integer) &optional silent)

159

(sparql-move transaction graph1-uri (sparql-graph-argument graph2-uri) silent)))

160

161

;;; revision properties

162

163

(defmethod compute-revision-uri ((revision repository-revision))

164

(let ((revision-id (repository-revision-id revision))

165

(*strict-vocabulary-terms* nil))

166

(when revision-id

167

(intern-iri (format nil "urn:dydra:revision:~a" revision-id)))))

168

169

(defmethod compute-repository-revision-uri ((revision repository-revision))

170

"construct the uri which combines the repository url with the revision id as a query argument"

171

(let* ((repository (repository-revision-reference revision))

172

(account (repository-account repository))

173

(revision-id (repository-revision-id revision)))

174

     (intern-iri (apply #'concatenate 'string "http://" (site-name) "/" (compute-repository-id account repository)

175

(when revision-id (list "?revision=" revision-id))))))

176

177

(defgeneric revision-memento-uri (repository-revision)

178

   (:documentation "Compute a dereferencable url to be used to peform requests against the specific repository revision.")

179

(:method ((revision repository-revision))

180

(let ((revision-id (repository-revision-id revision))

181

(repository-uri (repository-uri (repository-revision-reference revision))))

182

(if revision-id

183

(intern-iri (format nil "~a?revision-id=~a" (iri-lexical-form repository-uri) revision-id))

184

repository-uri))))

185

186

(defun compute-repository-metadata-uri (account-name repository-name &rest path)

187

   (intern-iri (format nil "http://~a/accounts/~a/repositories/~a~{/~a~}" (site-name) account-name repository-name path)))

188

189

(defun compute-repository-store-uri (account-name repository-name &rest path)

190

(intern-iri (format nil "http://~a/~a/~a~{/~a~}" (site-name) account-name repository-name path)))

191

192

(defun compute-initial-repository-authorization-graph (account-name repository-name)

193

(let* ((owner-uri (compute-user-identifier account-name))

194

(repository-uri (compute-repository-identifier account-name repository-name))

195

(repository-access-node (cons-global-blank-node :prefix "acl"))

196

            (graphstore-repository-uri (intern-iri (format nil "http://~a/~a/~a" (site-name) account-name repository-name)))

197

            (metadata-repository-uri (intern-iri (format nil "http://~a/accounts/~a/repositories/~a" (site-name) account-name repository-name)))

198

            (sesame-repository-uri (intern-iri (format nil "http://~a/~a/repositories/~a" (site-name) account-name repository-name))))

199

(append

200

`(;; establish owner authorizations for the repository

201

;; these cover metadata and content, as they include control access

202

203

         (spocq.a:|quad| ,repository-access-node |acl|:|accessTo| ,graphstore-repository-uri ,repository-uri)

204

205

206

207

208

209

210

(when (and (equal repository-name *system-repository-name*)

211

(equal account-name *system-repository-name*))

212

;; add default auth nodes for system resources

213

(let ((read-access-node (cons-global-blank-node :prefix "acl"))

214

(transaction-log-resource (merge-and-intern-iri "/admin/history/transactions")))

215

           `((spocq.a:|quad| ,read-access-node |acl|:|accessTo| ,transaction-log-resource ,transaction-log-resource)

216

217

             ;; require at least an authenticated use and leave final action to respetive operation

218

             (spocq.a:|quad| ,read-access-node |acl|:|agent| |urn:dydra|:|User| ,transaction-log-resource)))))))

219

220

(defgeneric compute-initial-repository-metadata (repository)

221

(:method ((repository repository))

222

(let* ((account (repository-account repository))

223

(account-uri (account-identifier account))

224

(owner-uri (compute-user-identifier (account-name account)))

225

(repository-uri (repository-identifier repository))

226

(name (repository-name repository)))

227

`(:system

228

229

230

231

232

233

234

235

236

237

(spocq.a:|triple| |foaf|:|Agent| |rdf|:|type| |rdfs|:|Class|)

238

(spocq.a:|triple| |foaf|:|Person| |rdf|:|type| |rdfs|:|Class|)

239

(spocq.a:|triple| |urn:dydra|:|Account| |rdf|:|type| |rdfs|:|Class|)

240

(spocq.a:|triple| |urn:dydra|:|Group| |rdf|:|type| |rdfs|:|Class|)

241

(spocq.a:|triple| |urn:dydra|:|LocatedAgent| |rdf|:|type| |rdfs|:|Class|)

242

(spocq.a:|triple| |urn:dydra|:|Repository| |rdf|:|type| |rdfs|:|Class|)

243

(spocq.a:|triple| |urn:dydra|:|User| |rdf|:|type| |rdfs|:|Class|)

244

245

246

247

248

249

)

250

:account

251

,(compute-initial-resource-authorization-graph repository)))))

252

253

254

 (defmethod  repository-pattern-count ((repository repository) (subject t) (predicate t) (object t) (context t))

255

1)

256

257

(defgeneric read-repository-pattern-count (repository subject predicate object context) )

258

259

(defgeneric read-repository-statement-count (repository)

260

(:method ((repository-id string))

261

(read-repository-statement-count (repository repository-id)))

262

(:method ((repository repository))

263

1))

264

265

(defgeneric repository-index (repository predicate-iri)

266

(:method ((repository t) (predicate-iri t))

267

(gethash predicate-iri *predicate-indices*))

268

269

(:method ((transaction transaction) (predicate-iri t))

270

(repository-index (transaction-repository transaction) predicate-iri)))

271

272

(defgeneric repository-write-date (repository)

273

(:method ((repository-id string))

274

(repository-write-date (repository repository-id))))

275

276

(defgeneric repository-revision-write-date (repository revision-id)

277

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

278

(repository-revision-write-date (repository repository-id) revision-id)))

279

280

(defgeneric repository-write-timestamp (repository)

281

(:method ((repository-id string))

282

(repository-write-timestamp (repository repository-id))))

283

284

285

(defgeneric repository-pattern-term-number (transaction term)

286

(:documentation "return the respective term number fro a pattern term.

287

Account for variables and blank nodes in addition to term values"))

288

289

(defgeneric repository-all-contexts-term (repository)

290

(:method ((transaction transaction))

291

(repository-all-contexts-term (transaction-repository transaction))))

292

293

(defgeneric repository-all-contexts-term-number (repository)

294

(:method ((transaction transaction))

295

(repository-all-contexts-term-number (transaction-repository transaction)))

296

(:method ((repository repository))

297

(repository-object-term-number repository (repository-all-contexts-term repository))))

298

299

(defgeneric repository-context-term-number (repository context-object)

300

(:documentation "given a symbolic designator for a context, return the respective term number.

301

This applies particularly to distinguished designators, such as all, named, default, nil, and t, but

302

permits arbitrary context uri as well, in which case it delegates to repository-object-term-number."))

303

304

(defmethod repository-default-context-term ((transaction transaction))

305

(let ((revision (transaction-revision transaction)))

306

(if revision (repository-default-context-term revision) (default-context-term))))

307

308

(defgeneric repository-default-context-term (repository)

309

(:method ((repository repository))

310

(metadata-default-context-term repository)))

311

312

(defgeneric repository-default-context-term-number (repository)

313

(:method ((transaction transaction))

314

(repository-object-term-number transaction (repository-default-context-term transaction)))

315

(:method ((repository repository))

316

(repository-object-term-number repository (repository-default-context-term repository))))

317

318

(defmethod repository-named-contexts-term ((transaction transaction))

319

(let ((revision (transaction-revision transaction)))

320

(if revision (repository-named-contexts-term revision) (default-context-term))))

321

322

(defgeneric repository-intern-property-path (context path-verb)

323

)

324

325

326

;;; iteration

327

;;;

328

329

330

331

332

(defun match-subject (&key (transaction *transaction*)

333

(wild (repository-wildcard-term transaction))

334

(g wild)

335

(p wild)

336

(o wild))

337

(flet ((decode-term (c s p o)

338

(declare (ignore c p o))

339

(return-from match-subject s)))

340

(declare (dynamic-extent #'decode-term))

341

(repository-call-with-matched-terms #'decode-term transaction wild p o :context g)

342

+null-term-id+))

343

344

(defun match-object (&key (transaction *transaction*)

345

(wild (repository-wildcard-term transaction))

346

(g wild)

347

(s wild)

348

(p wild))

349

(flet ((decode-term (c s p o)

350

(declare (ignore c s p))

351

;;(print (list c s p o))

352

(return-from match-object o)))

353

(declare (dynamic-extent #'decode-term))

354

(repository-call-with-matched-terms #'decode-term transaction s p wild :context g)

355

+null-term-id+))

356

357

(defun match-predicate (&key (transaction *transaction*)

358

(wild (repository-wildcard-term transaction))

359

(g wild)

360

(s wild)

361

(o wild))

362

(flet ((decode-term (c s p o)

363

(declare (ignore c s o))

364

(return-from match-predicate p)))

365

(declare (dynamic-extent #'decode-term))

366

(repository-call-with-matched-terms #'decode-term transaction s wild o :context g)

367

+null-term-id+))

368

369

(defmacro do-repository-contexts ((variable &key repository transaction

370

                                             (repository-handle (or repository transaction (error "repository-handle is required.")))

371

(distinct t d-s)

372

                                             (default (error "default must be supplied")))

373

&body body)

374

(let ((op (cons-symbol nil 'do-repository-contexts)))

375

`(flet ((,op (,variable)

376

(block do-repository-contexts

377

,@body)))

378

(declare (dynamic-extent #',op))

379

(map-repository-contexts #',op ,repository-handle

380

:default ,default

381

,@(when d-s `(:distinct ,distinct))))))

382

383

(defmacro do-repository-subjects ((variable &key (repository-handle (error "repository-handle is required."))

384

                                             (context nil c-s) (distinct t d-s))

385

&body body)

386

(let ((op (cons-symbol nil 'do-repository-subjects)))

387

`(flet ((,op (,variable)

388

(block do-repository-subjects

389

,@body)))

390

(declare (dynamic-extent #',op))

391

(map-repository-subjects #',op ,repository-handle

392

,@(when c-s `(:context ,context))

393

,@(when d-s `(:distinct ,distinct))))))

394

395

 (defmacro do-repository-predicates ((variable &key (repository-handle (error "repository-handle is required."))

396

                                             (context nil c-s) (distinct t d-s))

397

&body body)

398

(let ((op (cons-symbol nil 'do-repository-predicates)))

399

`(flet ((,op (,variable)

400

(block do-repository-predicates

401

,@body)))

402

(declare (dynamic-extent #',op))

403

(map-repository-predicates #',op ,repository-handle

404

,@(when c-s `(:context ,context))

405

,@(when d-s `(:distinct ,distinct))))))

406

407

(defmacro do-repository-objects ((variable &key (repository-handle (error "repository-handle is required."))

408

                                             (context nil c-s) (distinct t d-s))

409

&body body)

410

(let ((op (cons-symbol nil 'do-repository-objects)))

411

`(flet ((,op (,variable)

412

(block do-repository-objects

413

,@body)))

414

(declare (dynamic-extent #',op))

415

(map-repository-objects #',op ,repository-handle

416

,@(when c-s `(:context ,context))

417

,@(when d-s `(:distinct ,distinct))))))

418

419

#+digitool (setf (ccl:assq 'do-repository-contexts ccl:*fred-special-indent-alist*) 1)

420

#+digitool (setf (ccl:assq 'do-repository-subjects ccl:*fred-special-indent-alist*) 1)

421

#+digitool (setf (ccl:assq 'do-repository-predicates ccl:*fred-special-indent-alist*) 1)

422

#+digitool (setf (ccl:assq 'do-repository-objects ccl:*fred-special-indent-alist*) 1)

423

424

425

(defun list-repository-context-term-numbers (&key (repository-handle *transaction*))

426

(collect-list (collect)

427

(map-repository-contexts #'collect repository-handle :distinct t)))

428

429

(defun list-repository-context-objects (&rest args &key repository-handle)

430

(declare (ignore repository-handle))

431

(mapcar #'term-number-object (apply #'list-repository-context-term-numbers args)))

432

433

434

(defun spocq.e:contexts (&key (repository-handle *transaction*)

435

(dimensions '(?::context))

436

(distinct t))

437

(let ((result-channel (make-channel :name (list 'spocq.a::|contexts| (task-id *query*))

438

:dimensions dimensions)))

439

(flet ((process-contexts (result-channel repository-handle dimensions)

440

(trace-algebra process-contexts repository-handle dimensions)

441

(let* ((result-page nil)

442

(result-page-length 0)

443

(result-index 0))

444

(labels ((contexts-continuation (id)

445

(next-solution-location)

446

(setf (aref result-page result-index 0) id))

447

(next-solution-location ()

448

(when (>= (incf result-index) result-page-length)

449

(when result-page (put-page result-page))

450

                             (setf result-page (new-field-page result-channel *field-page-length* 1)

451

                                   result-page-length (array-dimension result-page 0)

452

result-index 0)))

453

(complete-solutions ()

454

(when result-page

455

(let ((page-result-count (1+ result-index)))

456

(when (< page-result-count result-page-length)

457

                                 (setf result-page (adjust-page result-page (list page-result-count 1)))))

458

(put-page result-page))

459

(complete-field result-channel)

460

(return-from process-contexts))

461

(put-page (page)

462

                           (trace-algebra process-contexts dimensions (term-value-field page))

463

(put-field-page result-channel page)))

464

(declare (dynamic-extent #'contexts-continuation))

465

                  (map-repository-contexts #'contexts-continuation repository-handle :distinct distinct)

466

(complete-solutions)))))

467

(make-solution-generator :dimensions dimensions

468

                                :expression (list #'process-contexts result-channel repository-handle dimensions)

469

:channel result-channel))))

470

471

472

(defun list-repository-subject-term-numbers (&key (repository-handle *transaction*) (context t))

473

(collect-list (collect)

474

(map-repository-subjects #'collect repository-handle :context context :distinct t)))

475

476

(defun list-repository-subject-objects (&rest args &key repository-handle context)

477

(declare (ignore repository-handle context)

478

(dynamic-extent args))

479

(mapcar #'term-number-object (apply #'list-repository-subject-term-numbers args)))

480

481

(defun spocq.e:subjects (&key (repository-handle *transaction*)

482

(dimensions '(?::subject))

483

(context t)

484

(distinct t))

485

(let ((result-channel (make-channel :name (list 'spocq.a::|subjects| (task-id *query*))

486

:dimensions dimensions)))

487

(flet ((process-subjects (result-channel repository-handle dimensions)

488

(trace-algebra process-subjects repository-handle dimensions)

489

(let* ((result-page nil)

490

(result-page-length 0)

491

(result-index 0))

492

(labels ((subjects-continuation (id)

493

(next-solution-location)

494

(setf (aref result-page result-index 0) id))

495

(next-solution-location ()

496

(when (>= (incf result-index) result-page-length)

497

(when result-page (put-page result-page))

498

                             (setf result-page (new-field-page result-channel *field-page-length* 1)

499

                                   result-page-length (array-dimension result-page 0)

500

result-index 0)))

501

(complete-solutions ()

502

(when result-page

503

(let ((page-result-count (1+ result-index)))

504

(when (< page-result-count result-page-length)

505

                                 (setf result-page (adjust-page result-page (list page-result-count 1)))))

506

(put-page result-page))

507

(complete-field result-channel)

508

(return-from process-subjects))

509

(put-page (page)

510

                           (trace-algebra process-subjects dimensions (term-value-field page))

511

(put-field-page result-channel page)))

512

(declare (dynamic-extent #'subjects-continuation))

513

                  (map-repository-subjects #'subjects-continuation repository-handle :context context :distinct distinct)

514

(complete-solutions)))))

515

(make-solution-generator :dimensions dimensions

516

                                :expression (list #'process-subjects  result-channel repository-handle dimensions)

517

:channel result-channel))))

518

519

520

(defun list-repository-predicate-term-numbers (&key (repository-handle *transaction*) (context t))

521

(collect-list (collect)

522

(map-repository-predicates #'collect repository-handle :context context)))

523

524

(defun list-repository-predicate-objects (&rest args &key repository-handle context)

525

(declare (ignore repository-handle context)

526

(dynamic-extent args))

527

(mapcar #'term-number-object (apply #'list-repository-predicate-term-numbers args)))

528

529

(defun spocq.e:predicates (&key (repository-handle *transaction*)

530

(dimensions '(?::predicate))

531

(context t)

532

(distinct t))

533

(let ((result-channel (make-channel :name (list 'spocq.a::|subjects| (task-id *query*))

534

:dimensions dimensions)))

535

(flet ((process-predicates (result-channel repository-handle dimensions)

536

(trace-algebra process-predicates repository-handle dimensions)

537

(let* ((result-page nil)

538

(result-page-length 0)

539

(result-index 0))

540

(labels ((predicates-continuation (id)

541

(next-solution-location)

542

(setf (aref result-page result-index 0) id))

543

(next-solution-location ()

544

(when (>= (incf result-index) result-page-length)

545

(when result-page (put-page result-page))

546

                             (setf result-page (new-field-page result-channel *field-page-length* 1)

547

                                   result-page-length (array-dimension result-page 0)

548

result-index 0)))

549

(complete-solutions ()

550

(when result-page

551

(let ((page-result-count (1+ result-index)))

552

(when (< page-result-count result-page-length)

553

                                 (setf result-page (adjust-page result-page (list page-result-count 1)))))

554

(put-page result-page))

555

(complete-field result-channel)

556

(return-from process-predicates))

557

(put-page (page)

558

                           (trace-algebra process-predicates dimensions (term-value-field page))

559

(put-field-page result-channel page)))

560

(declare (dynamic-extent #'predicates-continuation))

561

                  (map-repository-predicates #'predicates-continuation repository-handle :context context :distinct distinct)

562

(complete-solutions)))))

563

(make-solution-generator :dimensions dimensions

564

                                :expression (list #'process-predicates result-channel repository-handle dimensions)

565

:channel result-channel))))

566

567

568

(defun list-repository-object-term-numbers (&key (repository-handle *transaction*) (context t))

569

(collect-list (collect)

570

(map-repository-objects #'collect repository-handle :context context)))

571

572

(defun list-repository-object-objects (&rest args &key repository-handle context)

573

(declare (ignore repository-handle context)

574

(dynamic-extent args))

575

(mapcar #'term-number-object (apply #'list-repository-object-term-numbers args)))

576

577

(defun spocq.e:objects (&key (repository-handle *transaction*)

578

(dimensions '(?::object))

579

(context t)

580

(distinct t))

581

(let ((result-channel (make-channel :name (list 'spocq.a::|objects| (task-id *query*))

582

:dimensions dimensions)))

583

(flet ((process-objects (result-channel repository-handle dimensions)

584

(trace-algebra process-objects repository-handle dimensions)

585

(let* ((result-page nil)

586

(result-page-length 0)

587

(result-index 0))

588

(labels ((objects-continuation (id)

589

(next-solution-location)

590

(setf (aref result-page result-index 0) id))

591

(next-solution-location ()

592

(when (>= (incf result-index) result-page-length)

593

(when result-page (put-page result-page))

594

                             (setf result-page (new-field-page result-channel *field-page-length* 1)

595

                                   result-page-length (array-dimension result-page 0)

596

result-index 0)))

597

(complete-solutions ()

598

(when result-page

599

(let ((page-result-count (1+ result-index)))

600

(when (< page-result-count result-page-length)

601

                                 (setf result-page (adjust-page result-page (list page-result-count 1)))))

602

(put-page result-page))

603

(complete-field result-channel)

604

(return-from process-objects))

605

(put-page (page)

606

                           (trace-algebra process-objects dimensions (term-value-field page))

607

(put-field-page result-channel page)))

608

(declare (dynamic-extent #'objects-continuation))

609

                  (map-repository-objects #'objects-continuation repository-handle :context context :distinct distinct)

610

(complete-solutions)))))

611

(make-solution-generator :dimensions dimensions

612

                                :expression (list #'process-objects result-channel repository-handle dimensions)

613

:channel result-channel))))

614

615

616

617

;;; (map-repository-objects #'print (repository "5/5") :key #'cursor-object :declaration :term)

618

;;; "5/28" @hetzner == sp2b-50k

619

;;; "5/253" @hetzner == sp2b-250k

620

#+(or)

621

(let ((count 0) (repository (repository "5/28")))

622

(flet ((cnt (x) x (incf count)))

623

(format *trace-output* "~& w/ object id")

624

(setf count 0) (time (dotimes (x 100)

625

                            (map-repository-objects #'cnt repository :key #'rdfcache::cursor-object-number :declaration :term-number)))

626

(print count *trace-output*)

627

(format *trace-output* "~& w/ object instance")

628

(setf count 0) (time (dotimes (x 100)

629

                            (map-repository-objects #'cnt repository :key #'cursor-object :declaration :term)))

630

(print count *trace-output*)

631

(format *trace-output* "~& w/ nil")

632

(time (dotimes (x 100)

633

(map-repository-objects nil repository :declaration nil)))))

634

635

636

(defmacro do-repository-statements ((term-match-variables transaction context subject predicate object)

637

&body body)

638

"Given a repository handle and a term pattern, iterate over

639

    the matching term combinations with each match variable bound to the respective term. If a variable

640

position is nil, that term is ignored."

641

642

(let ((parameter-list (loop for variable in term-match-variables

643

if variable collect variable

644

else collect (gensym))))

645

`(flet ((do-repository-statements-continue ,parameter-list

646

,@(unless (every #'symbol-package parameter-list)

647

`((declare (ignore ,@(remove-if #'symbol-package parameter-list)))))

648

,@body))

649

(declare (dynamic-extent #'do-repository-statements-continue))

650

(repository-query #'do-repository-statements-continue ,transaction

651

,context ,subject ,predicate ,object))))

652

653

(defgeneric repository-delete-field (repository solution-field)

654

(:documentation

655

"Remove the given statements from the repository. If given triples (v/s quads) then remove

656

the statements from the static default graph, without allowing for the default/named/all option.

657

If a term is transient, do nothing.

658

When given quads, use the s-p-o-g order as for sexp-quads.")

659

660

(:method ((repository t) (field null))

661

0)

662

(:method ((repository repository) solution-field)

663

(with-open-repository (repository :read-only-p nil :normal-disposition :commit)

664

(repository-delete-field *transaction* solution-field)))

665

(:method ((transaction transaction) (solution-field cons))

666

(repository-delete-field transaction (term-number-statements solution-field))))

667

668

669

(defgeneric repository-insert-field (repository field)

670

(:method ((repository t) (field null))

671

0)

672

(:method ((repository repository) (solution-field t))

673

(repository-insert-field *transaction* solution-field))

674

(:method ((transaction transaction) (field cons))

675

(repository-insert-field transaction (term-number-statements field)))

676

677

(:method ((context t) (solution-field solution-field))

678

(repository-insert-field context

679

                              (term-number-field (solution-field-solutions solution-field)

680

                                                 ;; always convert to a quad field

681

:field-width 4))))

682

683

684

685

686

(defmethod task-lexical->spocq-term-registry ((context null))

687

(copy-registry *lexical->spocq-term-registry*))

688

689

(defmethod task-spocq->store-term-registry ((context null))

690

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

691

692

(defmethod task-store->spocq-term-registry ((context null))

693

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

694

695

696

;;; metadata

697

698

(defgeneric federation-enabled-p (repository)

699

(:method ((repository repository))

700

(member (metadata-federation-mode repository)

701

'(|urn:dydra|:|external| |urn:dydra|:|internal|))))

702

703

(defun repository-id-account-name (id)

704

(let ((pos (position #\/ id)))

705

(when pos

706

(subseq id 0 pos))))

707

708

(defun repository-id-repository-name (id)

709

(let ((pos (position #\/ id)))

710

(if pos

711

(subseq id (1+ pos))

712

id)))

713

714

715

#-sbcl

716

 (defun lookup-repository-id (&key account-name account-number (repository-name (error "repository-name is required."))

717

if-does-not-exist)

718

(error "NYI (lookup-repository-id ~@{~s~^ ~})"

719

account-name account-number repository-name if-does-not-exist))

720

721

#+(and sbcl (or)) ;; se below

722

(defun lookup-repository-id (&key external-name

723

                                   (account-name (repository-id-account-name external-name))

724

account-number

725

                                   (repository-name (or (repository-id-repository-name external-name)

726

                                                        (error "repository-name is required.")))

727

(host *mysql-host*) (database *mysql-database*)

728

(if-does-not-exist :error))

729

   "Given a symbolic repository designator, eg 'jhacker/repository-metadata', return a numeric designator, eg. '6/0'.

730

If the repository does not exist, return nil."

731

(assert (or account-name account-number) ()

732

"One of account-name or account-number is required.")

733

(let* ((query-command

734

(if account-number

735

             (format nil  "mysql -h ~a -u root ~a -BNe \"SELECT account_id, repositories.id from repositories where repositories.account_id = ~a and repositories.name = '~a';\""

736

host database account-number repository-name)

737

             (format nil  "mysql -h ~a -u root ~a -BNe \"SELECT account_id, repositories.id from repositories, accounts where repositories.account_id = accounts.id and accounts.name ='~a' and repositories.name = '~a';\""

738

host database account-name repository-name)))

739

(process

740

(sb-ext:run-program "/bin/sh" (list "-c" query-command)

741

:input nil :output :stream))

742

(id-pair (read-line (sb-ext:process-output process) nil)))

743

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

744

(or (when (stringp id-pair)

745

(let ((names (split-string id-pair #(#\space #\tab))))

746

(when (= (length names) 2)

747

(format nil "~{~a/~a~}" names))))

748

(ecase if-does-not-exist

749

(:error (error "repository not found: ~a: ~s" query-command id-pair))

750

((nil) nil)))))

751

752

;;; (lookup-repository-id :account-name "jhacker" :repository-name "tbl")

753

;;; (lookup-repository-id :account-number "6" :repository-name "tbl")

754

755

#+(and sbcl (or))

756

(defun lookup-repository-names (id &key

757

                                    (host *mysql-host*) (database *mysql-database*)

758

(if-does-not-exist :error))

759

"Given a repository id, eg '1/2', return a symbolic name, eg. 'jhacker/foaf'.

760

If the repository does notexists, return nil."

761

762

(destructuring-bind (account-number repository-number) (split-string id #(#\/))

763

(let* ((query-command

764

             (format nil  "mysql -h ~a -u root ~a -BNe \"SELECT accounts.cached_slug, repositories.cached_slug from repositories, accounts where repositories.account_id = ~a and repositories.id = '~a' and accounts.id = '~a';\""

765

host database account-number repository-number account-number))

766

(process

767

(sb-ext:run-program "/bin/sh" (list "-c" query-command)

768

:input nil :output :stream))

769

(name-pair (read-line (sb-ext:process-output process) nil)))

770

(cond ((stringp name-pair)

771

(unless (string-equal name-pair "NULL")

772

(apply #'values (split-string name-pair #(#\space #\tab)))))

773

(t

774

(ecase if-does-not-exist

775

(:error (error "repository not found: ~a." query-command))

776

((nil) nil)))))))

777

;;; (lookup-repository-name :id "253/1257") ;; on production

778

779

(defun lookup-repository-names (id &key (if-does-not-exist :error))

780

"Given a repository id, eg '1/2', return a symbolic name, eg. 'jhacker/foaf'.

781

If the repository does not exist, act according to :if-does-not-exist"

782

783

(flet ((true-directory-name (pathname)

784

(let ((true-pathname (probe-file pathname)))

785

(when true-pathname

786

(first (last (pathname-directory true-pathname)))))))

787

(destructuring-bind (account-identifier repository-identifier) (split-string id #(#\/))

788

(let* ((account-name (if (every #'digit-char-p account-identifier)

789

                              (true-directory-name (merge-pathnames (make-pathname :directory `(:relative "accounts"

790

                                                                                                          ,account-identifier))

791

                                                                    *metadata-root-pathname*))

792

account-identifier))

793

(repository-name (if (every #'digit-char-p repository-identifier)

794

(when account-name

795

                                   (true-directory-name (merge-pathnames (make-pathname :directory `(:relative "repositories"

796

                                                                                                               ,account-identifier

797

                                                                                                               ,repository-identifier))

798

                                                                         *metadata-root-pathname*)))

799

repository-identifier)))

800

(if (and account-name repository-name)

801

(values account-name repository-name)

802

(ecase if-does-not-exist

803

(:error (error "repository not found: ~a." id))

804

((nil) nil)))))))

805

806

;; (lookup-repository-names "6/1072")

807

808

#+(or)

809

(defun repository-truename (id &rest args)

810

"given an identifier, resolve it to a store identifier"

811

(declare (dynamic-extent args))

812

(destructuring-bind (account-identifier repository-identifier) (split-string id #(#\/))

813

(let* ((id-pathname (merge-pathnames (make-pathname :directory `(:relative "repositories"

814

                                                                                ,account-identifier

815

                                                                                ,repository-identifier))

816

*metadata-root-pathname*))

817

(true-pathname (probe-file id-pathname)))

818

(if true-pathname

819

(let ((id-directory (last (pathname-directory id-pathname) 2))

820

(true-directory (last (pathname-directory true-pathname) 2)))

821

(ecase *repository-resolution-mode*

822

(:internal-to-external

823

(if (equalp id-directory true-directory)

824

;; mapped external -> external;=,

825

;; if an admin db is present, check it for a corresponding name

826

(or (and *mysql-host*

827

(apply #'lookup-repository-id :external-name id

828

:if-does-not-exist nil

829

args))

830

id)

831

;; mapped internal -> external; use the given id

832

id))

833

(:external-to-internal

834

(if (equalp id-directory true-directory)

835

;; mapped internal->internal; use the given id

836

id

837

;; mapped external->internall construct the result

838

(format nil "~{~a/~a~}" true-directory)))

839

(:none

840

id)))

841

;; fallback on database - if present

842

(apply #'lookup-repository-id :external-name id args)))))

843

844

;;; the identifier is now identical to the namestring

845

(defun make-repository-id (&key (account-name (error "account-name is required"))

846

                                 (repository-name (error "repository-name is required")))

847

(format nil "~a/~a" account-name repository-name))

848

849

(defun lookup-repository-id (&key (account-name (error "account-name is required"))

850

                                   (repository-name (error "repository-name is required"))

851

&allow-other-keys)

852

(make-repository-id :account-name account-name :repository-name repository-name))

853

854

#+(or) ;; no purpose

855

(defun repository-truename (id &rest args)

856

"!!! vestige of the version which mapped between numeric and alpha identifiers."

857

(declare (ignore args))

858

id)

859

860

(defun entailment-repository-id ()

861

(or *entailment-repository-id*

862

(setq *entailment-repository-id*

863

(destructuring-bind (account repository) (split-string *entailment-repository-name* "/")

864

(lookup-repository-id :account-name account :repository-name repository)))

865

(error "The entailment repository (~s) is not present."

866

*entailment-repository-name*)))

867

868

869

(defgeneric repository-exists-p (repository)

870

(:documentation "Given a repository or its id, devolve to a file-system test

871

to see if the link to its root directory is present.

872

this tests for the symbolic link based on its name, not whether the target id corresponds

873

to an actual database directory with the repository components.

874

(see repository-pathname)")

875

876

(:method ((repository-id string))

877

(let ((pathname (repository-catalog-pathname repository-id)))

878

(when pathname

879

(probe-file pathname))))

880

#+(or)

881

(:method ((repository-id string))

882

(cli-probe-repository repository-id))

883

884

(:method ((repository repository))

885

(repository-exists-p (repository-id repository))))

886

887

888

#+(or)

889

(defgeneric repository-exists-p (repository)

890

(:documentation "Given a repository or its id, , test whether it exists.

891

Test by checking whether an authentication list exists.

892

The initial test will require the acl list to be loaded,

893

but subsequent tests should reduce to checking that the cached list is current.")

894

895

(:method ((repository-id string))

896

(repository-exists-p (repository repository-id)))

897

898

(:method ((repository repository))

899

(not (null (authorization-list-controls (resource-authorization-list repository))))))

900

901

902

903

#+(or) ;; superseded by instantiation with all name components for repository based metadata

904

(defgeneric repository-uri (repository)

905

(:documentation "GIven a REPOSITORY instance, return an uri which serves as its global designator.

906

    The identifier can appear in provenence descriptions and identifes the repository for service, query, and

907

other protocol requests. ")

908

(:method ((repository repository))

909

(or (get-repository-uri repository)

910

(setf-repository-uri (compute-repository-uri repository) repository))))

911

912

913

914

(defgeneric repository-external-name (repository)

915

(:documentation "GIven a REPOSITORY instance, return its external name. ")

916

(:method ((repository repository))

917

(or (get-repository-external-name repository)

918

(setf-repository-external-name (compute-repository-external-name repository) repository))))

919

920

(defgeneric compute-repository-external-name (repository)

921

(:method ((repository repository))

922

(multiple-value-bind (account repository)

923

(lookup-repository-names (repository-id repository))

924

(concatenate 'string account "/" repository))))

925

926

927

(defgeneric repository-service-description-uri (repository)

928

(:method ((repository t))

929

(repository-uri repository)))

930

931

(defgeneric repository-timemap-uri (repository)

932

(:method ((repository t))

933

(intern-iri (format nil "~a/timemap" (iri-lexical-form (repository-uri repository))))))

934

935

936

(defgeneric repository-account-name (repository)

937

(:documentation "Return the extrernal name of the repository's owning account.

938

On-demand, lookup based on the internal identifier.")

939

(:method ((repository null))

940

nil)

941

(:method ((repository repository))

942

(let ((account (repository-account repository)))

943

(when account

944

(account-name account)))))

945

946

947

(defun graph-indirect-uri (repository graph)

948

(intern-iri (format nil "~a?graph=~/format-iri-url-encoded/"

949

(iri-lexical-form (repository-uri repository))

950

graph)))

951

952

#+(or) ;; superseded by instantiation with all name components for repository based metadata

953

(defgeneric repository-repository-name (repository)

954

   (:documentation "Return the name of the repository relative to the owning account. On-demand, lookup based on the internal identifier.")

955

956

(:method ((repository repository))

957

(or (get-repository-repository-name repository)

958

(progn (update-repository-account repository)

959

(get-repository-repository-name repository)))))

960

961

962

(defgeneric repository-revision-ids (repository)

963

(:method ((repository-id string))

964

(repository-list-revision-ids repository-id))

965

(:method ((repository repository))

966

;; always repeat it for the repository itself

967

(repository-list-revision-ids (repository-id repository)))

968

(:method ((revision repository-revision))

969

(or (get-repository-revision-ids revision)

970

(let* ((id (repository-revision-id revision))

971

                (relative-ids (member id (repository-revision-ids (repository-revision-reference revision))

972

:test #'equal)))

973

(assert relative-ids ()

974

"No relative revision ids present: ~s" id)

975

(setf-repository-revision-ids relative-ids revision)))))

976

977

;;;!!! does not work as the revisions are not to be found to be statted

978

#+(or)

979

(defgeneric repository-revisions (repository)

980

(:method ((repository-id string))

981

(repository-revisions (repository repository-id)))

982

983

(:method ((repository repository))

984

(loop for uuid in (repository-list-revision-ids (repository-id repository))

985

with last-creation-time = nil

986

collect (let* ((path (concatenate 'string "/var/lib/rdfcache/revisions/" uuid))

987

(stat (sb-posix:stat path))

988

(ctime (+ AMQP:*TIMESTAMP-EPOCH* (sb-posix:stat-ctime stat))))

989

(make-instance (repository-revision-class repository)

990

:revision-id uuid :reference repository

991

:start-time ctime

992

:end-time (shiftf last-creation-time ctime))))))

993

994

(defgeneric repository-find-revision (repository &key revision-start-time revision-end-time &allow-other-keys)

995

(:method ((repository-id string) &rest args)

996

(apply #'repository-find-revision (repository repository-id) args))

997

998

#+(or) ;; file-system based version made obsolete by store structure changes

999

   (:method ((repository repository) &rest args &key revision-start-time revision-end-time if-does-not-exist &allow-other-keys)

1000

(flet ((make-revision (uuid start-time end-time)

1001

(make-instance (repository-revision-class repository)

1002

:revision-id uuid :reference repository

1003

:start-time start-time

1004

:end-time end-time))

1005

(temporal-intersection (r-start r-end test-start test-end)

1006

(and (or (null test-start) (>= test-start r-start))

1007

(or (null test-end) (null r-end) (<= r-end test-end))))

1008

(uuid-start-time (uuid)

1009

(let* ((path (concatenate 'string "/var/lib/rdfcache/revisions/" uuid))

1010

(stat (sb-posix:stat path)))

1011

(+ AMQP:*TIMESTAMP-EPOCH* (sb-posix:stat-ctime stat)))))

1012

(or (loop for uuid in (reverse (repository-list-revision-ids (repository-id repository)))

1013

for start-time = (uuid-start-time uuid)

1014

for end-time = nil then start-time

1015

                 when (temporal-intersection start-time end-time revision-start-time revision-end-time)

1016

do (return (make-revision uuid start-time end-time)))

1017

(ecase if-does-not-exist

1018

((nil) nil)

1019

(:error (error "repository revision not found: ~s: ~s." repository args))))))

1020

1021

   (:method ((repository repository) &rest args &key revision-start-time revision-end-time if-does-not-exist &allow-other-keys)

1022

(flet ((make-revision (uuid start-time end-time)

1023

(make-instance (repository-revision-class repository)

1024

:revision-id uuid :reference repository

1025

:start-time start-time

1026

:end-time end-time))

1027

(temporal-intersection (r-start r-end test-start test-end)

1028

(and (or (null test-start) (>= test-start r-start))

1029

(or (null test-end) (null r-end) (<= r-end test-end))))

1030

(uuid-start-time (uuid)

1031

(let* ((path (concatenate 'string "/var/lib/rdfcache/revisions/" uuid))

1032

(stat (sb-posix:stat path)))

1033

(+ AMQP:*TIMESTAMP-EPOCH* (sb-posix:stat-ctime stat)))))

1034

(or (loop for (nil uuid start-unix-time)

1035

in (repository-list-revision-metadata (repository-id repository))

1036

for end-unix-time = (spocq.e::unix-now) then start-unix-time

1037

             when (temporal-intersection start-unix-time end-unix-time revision-start-time revision-end-time)

1038

do (return (make-revision uuid start-unix-time end-unix-time)))

1039

(ecase if-does-not-exist

1040

((nil) nil)

1041

(:error (error "repository revision not found: ~s: ~s." repository args)))))))

1042

1043

1044

;;; on dev (repository-revisions (repository "6/1606"))

1045

;;; (repository-revisions "statistics/de4.dydra.com")

1046

;;; (repository-revisions "statistics/de1.dydra.com")

1047

1048

;;; revision resolution

1049

1050

(defgeneric repository-revision (revision-designator &key reference if-does-not-exist revision-class class)

1051

(:documentation "Given a reference repository and a revision identifier, resolve the designator

1052

    to a uuid and either retrieve the known instance or create a new one and register it in *repositories*.")

1053

(:method ((revision-designator t) &rest args &key reference if-does-not-exist revision-class class)

1054

(declare (dynamic-extent args)

1055

(ignore if-does-not-exist revision-class class))

1056

(apply #'compute-repository-revision reference revision-designator

1057

(plist-difference args '(:reference))))

1058

(:method ((repository repository) &rest args)

1059

(apply #'compute-repository-revision repository nil

1060

(plist-difference args '(:reference)))))

1061

1062

 (defgeneric compute-repository-revision (repository revision-designator &key if-does-not-exist revision-class class)

1063

(:documentation "Given a reference repository and a revision designator,

1064

compute a revision instance which reflects the designation.

1065

This caches and purges the revision by the same

1066

process as for repositories.

1067

Instantiation relies on (repository-revision-class repository).

1068

    The reference timestamp is not set here, but rather when the query runs in order to handle re-runs")

1069

1070

(:method ((revision repository-revision) (revision-designator t) &rest args)

1071

(apply #'compute-repository-revision (repository-revision-reference revision) revision-designator

1072

args))

1073

1074

(:method ((repository repository) (revision-designator symbol) &rest args)

1075

"treat a non-null symbol as the respective string"

1076

(apply #'compute-repository-revision repository (symbol-name revision-designator) args))

1077

1078

(:method ((repository repository) (revision-designator null) &rest args)

1079

     ;; the case when the revision applies to a repository without specific revision designator, use "HEAD"

1080

(apply #'compute-repository-revision repository "HEAD" args))

1081

1082

(:method ((repository repository) (revision-designator repository) &rest args)

1083

     ;; the case when the revision applies to a repository without specific revision designator, use "HEAD"

1084

(apply #'compute-repository-revision repository "HEAD" args))

1085

1086

(:method ((reference repository) (revision-designator string) &key (if-does-not-exist :error)

1087

(revision-class (repository-revision-class reference)) (class revision-class))

1088

;; this is the principle method:

1089

;; build a combined key to allow for the case where the repository is empty and

1090

;; therefor has no revision id

1091

     (let* ((revision-id (resolve-repository-revision-id reference :revision revision-designator :if-does-not-exist if-does-not-exist))

1092

(existing-instance (get-registry revision-id *repositories*))

1093

            (revision (if (and existing-instance (typep existing-instance class)) ;; allow class change to invalidate old instance

1094

existing-instance

1095

(setf (get-registry revision-id *repositories*)

1096

                                (make-instance class :revision-id revision-id :reference reference)))))

1097

       (assert (equal (repository-id reference) (repository-id (repository-revision-reference revision))) ()

1098

             "repository-revision: clone does not match reference : for designator->id ~s->~s : ~s != ~s"

1099

revision-designator revision-id

1100

(repository-id reference) (repository-id (repository-revision-reference revision)))

1101

revision)))

1102

1103

#+(or)

1104

(defmethod compute-repository-revision :around ((context t) (designator t) &rest args)

1105

(let ((result (call-next-method)))

1106

(log-warn "repository-revision: (~s ~s . ~s): ~s" context designator args result)

1107

result))

1108

1109

(defgeneric repository-revision-mutable-p (revision)

1110

(:method ((revision repository-revision))

1111

#+(or)

1112

;; do not use the reference revision, as a change there does not mean

1113

;; that the revision should not still track it

1114

(let ((reference (repository-revision-reference revision)))

1115

(when reference

1116

(equal (repository-revision-id revision)

1117

(repository-revision-id reference))))

1118

(let ((revision-id (repository-revision-id revision))

1119

(reference-revision-id (repository-revision-reference-revision-id revision)))

1120

;; allow case variation

1121

(and (stringp revision-id) (stringp reference-revision-id)

1122

(string-equal revision-id reference-revision-id)))))

1123

#+(or)

1124

(defmethod repository-revision-mutable-p :before ((revision t))

1125

(print :revision)

1126

(describe revision)

1127

(print :revision-reference)

1128

(describe (repository-revision-reference revision)))

1129

1130

1131

(defgeneric resolve-repository-id-revision-id (id &key if-does-not-exist)

1132

(:method ((id string) &key (revision "HEAD") (if-does-not-exist :error))

1133

(handler-bind ((error (lambda (c)

1134

(declare (ignore c))

1135

(case if-does-not-exist

1136

(:error )

1137

                               (t (return-from resolve-repository-id-revision-id if-does-not-exist))))))

1138

(if (equalp revision "HEAD")

1139

(setq revision "HEAD")

1140

(setq revision (string-downcase revision)))

1141

(rdfcache::resolve-repository id :revision revision))))

1142

1143

(defgeneric resolve-repository-revision-id (repository &key revision if-does-not-exist)

1144

(:documentation "Given a repository or one of its revisions or an abstract designator,

1145

determine the respective concrete latest revision and return the id.

1146

relies on a string based implementation for the cases where

1147

- the repository is not yet instantiated in order to avoid circular instantiation

1148

- the repository depends on the store only

1149

in the lmdb case, the information is retrieved from the lmdb environment.

1150

string : iff the reposit exists delegate it, otherwise to the store

1151

repository : use its id string, change no state (any caches are in the revision)

1152

no longer:

1153

repository-revision : for a 'fixed' revision return always the initial revision id;

1154

for a 'current' revision, return the latest id. If that id has changed,

1155

return the old revision id a second value.")

1156

1157

#+(or)

1158

(:method ((revision repository-revision))

1159

(let ((old (get-repository-revision-id revision))

1160

(reference-revision-id (repository-revision-reference-revision-id revision)))

1161

(if (equal old reference-revision-id)

1162

;; if the revision is to be always the latest, determine the current revision id

1163

(let ((new (rdfcache::resolve-repository

1164

(repository-id (repository-revision-reference revision)))))

1165

(if (equal old new)

1166

;; if unchanged just return it

1167

(values old nil)

1168

;; if changed, return new and old

1169

(values new old)))

1170

;; if the revision is fixed, return the initial id and retain caches

1171

(values old nil))))

1172

1173

(:method ((repository repository) &rest args)

1174

(apply #'resolve-repository-id-revision-id (repository-id repository) args))

1175

1176

(:method ((id string) &rest args)

1177

"iff the repository is known, delegate to the instance, otherwise use the id"

1178

(let ((repository (find-repository id)))

1179

(if repository

1180

(apply #'resolve-repository-revision-id repository args)

1181

(apply #'resolve-repository-id-revision-id id args)))))

1182

1183

(defgeneric service-repository (location &key if-does-not-exist class &allow-other-keys)

1184

(:documentation "Given location string, distinguish local from remote services and

1185

instantiate and cache a new repository instance of the appropriate kind.

1186

Return just the base repository.")

1187

1188

(:method ((location spocq:iri) &rest args)

1189

"Given something which was parsed from a query document, ensure that it is url-decoded"

1190

(apply #'service-repository (url-decode (spocq:iri-lexical-form location))

1191

args))

1192

1193

(:method ((uri puri:uri) &rest args)

1194

(apply #'service-repository (iri-lexical-form uri)

1195

args))

1196

1197

(:method ((location string) &rest args &key (if-does-not-exist :error) class)

1198

;; deconstruct, check cache, determine local or global

1199

(declare (ignorable if-does-not-exist))

1200

(assert (or (null class) (class-designator-p class) (subtypep class 'repository))

1201

()

1202

"service-repository: invalid class: ~s." class)

1203

(or (get-registry location *repositories*)

1204

(let ((scheme (parse-uri-scheme location)))

1205

(ecase scheme

1206

((nil)

1207

(error "service-repository: invalid location: ~s." location))

1208

((:http :https)

1209

(multiple-value-bind (protocol authority path view)

1210

(parse-url-authority+path location)

1211

(declare (ignore protocol))

1212

;; check for one of variations to permit static definition

1213

;; coerce protocol for id to https

1214

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

1215

                     (service-account-name (substitute-if #\- (complement #'alphanumericp) authority))

1216

                     (service-repository-name (substitute-if #\- (complement #'alphanumericp) path))

1217

(service-view-name (substitute-if #\- (complement #'alphanumericp) view))

1218

(resource-id (concatenate 'string "http://"

1219

(if view

1220

                                                   (concatenate 'string service-account-name "/" service-repository-name "/" service-view-name)

1221

                                                   (concatenate 'string service-account-name "/" service-repository-name)))))

1222

(or (get-registry resource-id *repositories*)

1223

(when local-repository-id (get-registry local-repository-id *repositories*))

1224

(get-registry authority *repositories*)

1225

;; iff not yet registered, determine whetehr local or remote, create

1226

;; accordingly and register

1227

(cond ((and local-repository-id

1228

(or (null class)

1229

(subtypep class *class.repository*)))

1230

                           ;; if local, instantiate a local repository based on the repository name

1231

                           ;; rely on the type regexp match in the repository operator

1232

#+(or)

1233

(unless class

1234

(if (parse-view-repository-id local-repository-id)

1235

(setf class 'internal-view-repository)

1236

(setf class *class.repository*)))

1237

;; register by location in addition to the id

1238

(setf (get-registry location *repositories*)

1239

                                 (repository local-repository-id :class class :external-name local-repository-id)))

1240

((eq *federation-mode* |urn:dydra|:|external|)

1241

(if class

1242

(assert (subtypep class *class.service-repository*) ()

1243

                                       "service-repository: invalid class: ~s." class)

1244

                               (setf class (or (service-location-class (concatenate 'string authority "/" path))

1245

'service-repository)))

1246

                           ;; use the most specific identifiers to instantiate a service repository

1247

                           ;; place the authority into the account and the path (+view) into the name proper

1248

;; reconstruct the id from those to

1249

                           ;; nb. rails mangels the repository name (not just the slug) fi a '/' is present

1250

                           (let* ((service-repository-id (make-repository-id :account-name service-account-name

1251

                                                                            :repository-name service-repository-name))

1252

(resource-uri (intern-iri resource-id)))

1253

;; register by location in addition to the id

1254

(setf (get-registry location *repositories*)

1255

                                   (apply #'repository service-repository-id ;; must have proper syntax

1256

:class class

1257

:if-does-not-exist :create

1258

:identifier resource-id

1259

:uri resource-uri

1260

                                          :account (account service-account-name)

1261

:name service-repository-name

1262

                                          :external-name location ; retain the full url for use in the external service operation

1263

args))))

1264

(t

1265

                           (error "service-repository: federation location not permitted in mode '~s': ~s."

1266

*federation-mode* location)))))))

1267

(:uuid )

1268

(:odbc

1269

(unless class

1270

(setf class 'hydra:|ODBCView|))

1271

(let ((uri (parse-uri-by-scheme scheme location)))

1272

(setf (get-registry location *repositories*)

1273

(apply #'repository class

1274

:id location

1275

:identifier uri

1276

:uri uri

1277

args))))

1278

)))))

1279

;;; (service-repository "http://localhost/jhacker/test")

1280

;;; (SERVICE-REPOSITORY <http://dbpedia.org/sparql>)

1281

;;; (SERVICE-REPOSITORY <http://ml.dydra.com/fbfpt-learning>)

1282

1283

1284

1285

(defun external-service-repository (location)

1286

(setf location (concatenate 'string "" location)) ; ensure it is a simple string

1287

(or (get-registry location *repositories*)

1288

(let ((class (service-location-class location)))

1289

(setf (get-registry location *repositories*)

1290

;; otherwise instantiate a service repository

1291

(repository class :id location :external-name location)))))

1292

1293

(defparameter *service-location-classes* (make-hash-table :test 'equalp))

1294

1295

(defun service-location-class (location)

1296

(gethash location *service-location-classes* *class.service-repository*))

1297

1298

(defun (setf service-location-class) (class location)

1299

(assert (subtypep class 'service-repository) ()

1300

"invalid service location class: ~s" class)

1301

(setf (gethash location *service-location-classes*) class))

1302

1303

1304

;;; access operators

1305

1306

(defgeneric repository-match-field (transaction context subject predicate object &rest args)

1307

(:documentation "Given a repository designator and statement pattern elements (as c s p o),

1308

as term objects, match that statement pattern and return a list of term solutions.

1309

Allow for a start/end slice as well as first/last revision specification.

1310

For rlmdb, specializations resolve designators to a repository instance, which then delegates

1311

to the rlmdb:map-repository-statements for the respective rlmdb:repository.

1312

For rdfcache, specializations resolve to a transaction, which then performs a matrix match.")

1313

1314

(:method ((repository repository) context subject predicate object &rest args)

1315

(declare (dynamic-extent args))

1316

(with-open-repository (repository :read-only-p t :normal-disposition :abort)

1317

(apply #'repository-match-field *transaction* context subject predicate object args)))

1318

(:method ((repository string) context subject predicate object &rest args)

1319

(apply #'repository-match-field (repository repository) context subject predicate object args)))

1320

;;; (repository-match-field "jhacker/test" nil nil nil nil)

1321

;;; (time (dotimes (x 100) (repository-match-field "jhacker/test" nil nil nil nil))

1322

1323

(defgeneric repository-matrix-field (repository context subject predicate object

1324

                                      &key start end dimensions wild-blank-nodes-p)

1325

(:method ((repository-id string) context subject predicate object &rest args)

1326

(declare (dynamic-extent args))

1327

(with-open-transaction (repository-id)

1328

(apply #'repository-matrix-field *transaction* context subject predicate object args)))

1329

(:method ((repository repository) context subject predicate object &rest args)

1330

(declare (dynamic-extent args))

1331

(apply #'repository-matrix-field (repository-id repository) context subject predicate object

1332

args)))

1333

1334

(defgeneric repository-match-matrix (repository matrix context subject predicate object

1335

&key start end)

1336

(:method ((repository repository) matrix context subject predicate object &rest args)

1337

(declare (dynamic-extent args))

1338

(with-open-repository (repository :read-only-p t :normal-disposition :abort)

1339

(apply #'repository-match-matrix *transaction* context subject predicate object args))))

1340

1341

#+(or)

1342

;;; this makes no sense, as they need to be http headers

1343

;;; - see execute-graph-store-query reference to set-memento-response-headers

1344

(defun write-timemap-headers (task stream)

1345

(let ((revision (task-revision task)))

1346

(format stream "~&Vary: accept-datetime" )

1347

(format stream "~&Link: ~a; rel=timemap" (repository-timemap-uri (task-repository task)))

1348

(format stream "~&Link: ~a; rel=timegate" (repository-uri (task-repository task)))

1349

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

1350

(format stream "~&Memento-Datetime: ~a" (repository-revision-date-time revision))

1351

(format stream "~&Link: ~a; rel=original" (repository-uri (task-repository task))))))

1352

1353

1354

1355

;;; internal / ephemeral repositories

1356

1357

(defgeneric ensure-ephemeral-repository (repository name)

1358

(:documentation "find or construct the named content for a given repository.")

1359

(:method ((repository repository) name)

1360

(or (gethash name (repository-library-cache repository))

1361

(setf (gethash name (repository-library-cache repository))

1362

(or (compute-ephemeral-repository repository name)

1363

(spocq.e:resource-not-found-error :identifier name))))))

1364

1365

(defgeneric compute-ephemeral-repository (repository name)

1366

(:method ((repository repository) (name t))

1367

nil))

1368

1369

(defmethod compute-ephemeral-repository ((repository repository) (name (eql |urn:dydra|:|service-description|)))

1370

(let* ((service-description (repository-service-description (repository-id repository)))

1371

(name (concatenate 'string (repository-name repository) ".service-description"))

1372

(account (repository-account repository))

1373

(content (make-ephemeral-repository repository

1374

                                              :account-name (account-name account)

1375

:repository-name name

1376

                                              :id (make-repository-id :account-name (account-name account) :repository-name name)

1377

                                              :content service-description)))

1378

content))

1379

1380

;;; repository sizes

1381

#+(or)

1382

;;; version which uses turtle encoding and rdfcache revisions, for each of which it

1383

;;; runs call-with-matched-terms in a respective transaction

1384

(defun compute-repository-size (repository &key (literal-term-size 0))

1385

(let* ((revisions (repository-revision-ids repository))

1386

(statements (make-hash-table :test 'equal))

1387

(terms (make-hash-table :test 'equal))

1388

(statement-count 0)

1389

(byte-count 0)

1390

(buffer (make-array 128 :element-type 'character :adjustable t :fill-pointer 0))

1391

(string-datatype "^^<http://www.w3.org/2001/XMLSchema#string>")

1392

(sd-length (length string-datatype)))

1393

(with-output-to-string (stream buffer)

1394

(flet ((count-quads (subject predicate object graph)

1395

(incf statement-count)

1396

(let ((stmt (list subject predicate object graph)))

1397

(unless (gethash stmt statements)

1398

(setf (gethash stmt statements) statement-count)

1399

(loop for term-number in stmt

1400

do (unless (gethash term-number terms)

1401

(setf (gethash term-number terms) t)

1402

(setf (fill-pointer buffer) 0)

1403

(encode-turtle-term-number term-number stream)

1404

(let ((length (length buffer)))

1405

;; if a string, count just the lexical form,

1406

                               ;; for other literals, count a constant size (likely 0)

1407

                               ;; for other terms, count the full encoded string length

1408

(cond ((and (> length sd-length)

1409

                                           (string-equal buffer string-datatype :start1 (- length sd-length)))

1410

(incf byte-count (- length sd-length)))

1411

                                     ((and literal-term-size (search "^^" buffer :test #'char-equal))

1412

(incf byte-count literal-term-size))

1413

(t

1414

                                      (incf byte-count (length buffer)))))))))))

1415

(declare (dynamic-extent #'count-quads))

1416

         (format *trace-output* "~%revision      bytes   statementsTotal statementsUnique        termsUnique")

1417

(loop for revision in revisions

1418

with *repository* = (repository repository)

1419

;; do (print revision)

1420

do (with-open-transaction (repository :revision-id revision ;;:read-only-p t

1421

                                                 :normal-disposition :abort

1422

                                                 :operation 'spocq.a:|select|)

1423

;; (print *repository*)

1424

;; (print *transaction*)

1425

;;!! this is counting head only - just repeating it for all revisions

1426

                (repository-call-with-matched-terms #'count-quads *transaction* 0 0 0 :context 0))

1427

do (format *trace-output* "~%~s ~s ~s ~s ~s"

1428

                      revision byte-count statement-count (hash-table-count statements) (hash-table-count terms))

1429

(finish-output *trace-output*))

1430

(list repository

1431

:bytes (+ byte-count (* (hash-table-count terms) 12) (* statement-count 32))

1432

:terms (hash-table-count terms)

1433

:unique-statements (hash-table-count statements)

1434

:statements statement-count)))))

1435

1436

;;; version which uses the term structures directly,

1437

;;; rdfcache-fetch-term -> %%cursor-fetch-term -> rdfcache_ffi_fetch_term -> const dydra::term term(term_no);

1438

;;; it uses no rdf transaction, but instead looks at the rlmdb index.

1439

1440

;;; term.cc : term::fetch_record : terms = global.store->terms(); term.fetch(term_id);

1441

1442

;;; nb. limited to rdfcache repositories as the index complements vary

1443

(defgeneric compute-repository-size (repository &key literal-term-size verbose)

1444

(:method ((repository string) &rest args)

1445

(apply #'compute-repository-size (repository repository) args))

1446

1447

(:method ((repository rdfcache-repository) &key (literal-term-size 0) (verbose nil))

1448

(declare (ignore literal-term-size))

1449

(let* (;(revisions (or (repository-revision-ids repository) (list :head)))

1450

(repository-id (repository-id repository))

1451

(terms (make-hash-table :test 'equal))

1452

(strings (make-hash-table :test 'equal))

1453

(term-count 0)

1454

(term-byte-count 0)

1455

(index-bytes 0)

1456

(index-node-bytes 0)

1457

(index-leaf-bytes 0)

1458

(index-count 0)

1459

(statement-count-versioned 0))

1460

(labels ((term-size (term-number)

1461

(destructuring-bind (&key type value-string language-string datatype-string value)

1462

(rlmdb:term-elements term-number)

1463

(declare (ignore type value))

1464

(+ (if value-string (length value-string) 0)

1465

(if language-string

1466

(if (gethash language-string strings) 0

1467

                             (setf (gethash language-string strings) (length language-string)))

1468

0)

1469

(if datatype-string

1470

(if (gethash datatype-string strings) 0

1471

                             (setf (gethash datatype-string strings) (length datatype-string)))

1472

0)

1473

12)))

1474

(collect-term (term-number)

1475

(unless (gethash term-number terms)

1476

(setf (gethash term-number terms) (incf term-count))))

1477

(count-map-bytes (continue version-map)

1478

;; record the version map size and the added/removed count

1479

(typecase version-map

1480

(ordinal-map

1481

                   (incf index-leaf-bytes (foreign-ordinal-map-length version-map)) ;; version map in leaf node

1482

                   (incf statement-count-versioned (ceiling (spocq.i::foreign-ordinal-map-length version-map) 2)))

1483

(timestamp-map

1484

                   (incf index-leaf-bytes (* (length (timestamp-map-vector version-map)) 16)) ;; uuid vectors

1485

;; sha1 entry - this is missing for successive entries

1486

(incf index-leaf-bytes 40)

1487

))

1488

(funcall continue 0 1)) ;; -> invoke count-statement-bytes

1489

(_term-number-object (term-number)

1490

(if (= 4294967295 term-number)

1491

|urn:dydra|:|default|

1492

(rlmdb:term-number-value term-number)))

1493

(collect-statement-terms (%quad start end)

1494

(declare (ignore start end))

1495

(collect-term (%quad-context %quad))

1496

(collect-term (%quad-subject %quad))

1497

(collect-term (%quad-predicate %quad))

1498

(collect-term (%quad-object %quad))

1499

;; not quite true,as it is just the leaf nodex

1500

;; see http://www.lmdb.tech/doc/group__internal.html#structMDB__node

1501

                ;; (incf index-bytes (load-time-value (CFFI:FOREIGN-TYPE-SIZE '(:struct liblmdb:val))))

1502

;; sum for both versioned and unversioned nodes

1503

(incf index-count)

1504

                (incf index-leaf-bytes (load-time-value (+ (* 4 (CFFI:FOREIGN-TYPE-SIZE :short)) ;; lmdb space

1505

                                                           (cffi:foreign-type-size '(:struct quad))))) ;; leaf node

1506

t)

1507

(stat-size ()

1508

                (let ((process (run-program "/bin/bash" `("/opt/rails/script/repository_size" ,repository-id) :wait t :output :stream)))

1509

(assert process () "no process for size: ~s" repository-id)

1510

                  (unwind-protect (parse-integer (read-line (run-program-output process)) :junk-allowed t)

1511

(close (run-program-output process))

1512

(run-program-close process))))

1513

(compressed-size ()

1514

                (let ((process (run-program "/bin/bash" `("/opt/rails/script/repository_compressed_size" ,repository-id) :wait t :output :stream)))

1515

(assert process () "no process for size: ~s" repository-id)

1516

                  (unwind-protect (parse-integer (read-line (run-program-output process)) :junk-allowed t)

1517

(close (run-program-output process))

1518

(run-program-close process)))))

1519

(declare (dynamic-extent #'count-map-bytes #'collect-statement-terms))

1520

(when verbose

1521

         (format *trace-output* "~%revision      bytes   statementsTotal statementsUnique        termsUnique"))

1522

;; (print (list :ib index-bytes))

1523

(multiple-value-bind (scanned matched match-cache)

1524

                            (rlmdb:map-repository-statements-filtered #'collect-statement-terms repository #(0 0 0 0) #'count-map-bytes)

1525

(declare (ignore scanned matched))

1526

;; ("gspo" "gpos" "gosp" "spog" "posg" "ospg")

1527

;; need to add inner nodes

1528

         ;; ? (* per index = (+ (+ (* 4 2) (* 8 2)) (loop for count = (floor index-count 2) then (floor count 2) until (= count 0) sum count))

1529

;; aggregate term sizes

1530

(loop for term-number being each hash-key of terms

1531

do (incf term-byte-count (term-size term-number)))

1532

;; aggregate inner nodes

1533

(setf index-node-bytes (* (load-time-value (+ (* 4 (CFFI:FOREIGN-TYPE-SIZE :short))

1534

                                                       (cffi:foreign-type-size '(:struct quad))))

1535

                                   (loop for inner-count = (floor index-count 2) then (floor inner-count 2) until (= inner-count 0) sum inner-count)))

1536

(when match-cache

1537

#+(or)

1538

(loop for entry being each hash-key of match-cache

1539

do (incf index-node-bytes (reduce #'+ entry :key #'length :initial-value 0))))

1540

;; multiply by number of indeces

1541

(setf index-bytes (* index-bytes (length rlmdb:+quad-database-names+)))

1542

(let ((stat-compressed-bytes (compressed-size)))

1543

(list repository-id

1544

:statement-count index-count

1545

:statement-count-versioned statement-count-versioned

1546

:terms (hash-table-count terms)

1547

:index-bytes (+ index-node-bytes index-leaf-bytes)

1548

:index-leaf-bytes index-leaf-bytes

1549

:index-node-bytes index-node-bytes

1550

:term-bytes term-byte-count

1551

:stat-bytes (stat-size)

1552

:stat-compressed-bytes stat-compressed-bytes

1553

:total-bytes (+ term-byte-count stat-compressed-bytes))))))))

1554

;;; (compute-repository-size "james/foaf")