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

Kind	Covered	All	%
expression	340	1480	23.0
branch	42	182	23.1

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 "persistant classes"

6

"Mediate data between a persistent store and an application or user interface

7

by interposing instances which combine a projection of the persistent state

8

with access logic, to stage the data for application processing or for presentation and

9

to render changes back to the store.

10

Instance state is held as slot values where each slot is associated with predicates from the store.

11

The state is exchanged with the store as graph field deltas -- added and removed triple statements.

12

The initial state arrives from the store as a complete field and updates take the form of paired

13

triple sets - one additions and one deletions. The additions are used to reinitialize the instance

14

and the delete/add pait is merged with the existing cache.

15

16

At the clos/store interface quad field statements are read the form (c s p o),

17

but written as (|quad| s p o c), as those are the current library APIs.

18

  At the presentation interface, the statement encoding is as triples in the form (s p o) in both directions.

19

In order to permit simpler login in the application model, some value carrry special meaning:

20

21

presentation clos store

22

field model field

23

----------------------------------------------------------------------

24

true t true^^boolean

25

       false                      nil                   false^^boolean

26

27

Deletion is specified with the explicit deletion set.

28

"

29

)

30

31

32

(defparameter *decode-presentation-graph.mode* :eval)

33

(defparameter *decode-presentation-graph.verbose* nil)

34

(defparameter *decode-store-graph.mode* :eval)

35

36

37

(defparameter *persistence-context* (make-registry :weakness :value :test 'equalp)

38

"Serves as the context to identify instances known to the UI and store interfaces in terms of

39

a subject iri. The operators which compute or modified instances from a field use this to resolve

40

  cross-references against existing instances. They cache all newly constructed result, but It is weak in

41

terms of the value, such that once a value is no longer reachable, it will be released.")

42

43

;;;

44

45

(defclass identified-class (standard-class)

46

()

47

(:documentation "declare support for instantiation protocols where the initargs

48

include an identifier."))

49

50

(defclass cached-class (identified-class)

51

((cache

52

:initform (make-registry :weakness :value :test 'equalp)

53

:reader class-cache))

54

(:documentation "provide support to cache instances based on identifier."))

55

56

(defclass persistent-class (identified-class)

57

((persistent-slots

58

:initform ()

59

:reader get-class-persistent-slots :writer setf-class-persistent-slots))

60

(:documentation

61

"The persistent-class meta-class provides the slot meta-data to correlate state with statements

62

based on the predicate terms. It specializes its definitions wth persistent-class-slot-definition

63

to include a store property for exchanges with the store and encode and decode properties for

64

echanges with the ui."))

65

66

(defclass cached-persistent-class (cached-class persistent-class)

67

()

68

(:documentation "combine support for cached and persistent instances."))

69

70

71

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

72

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

73

(superclass standard-class))

74

t)

75

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

76

(superclass standard-class))

77

t)

78

;; standard subclasses to permit specialized forms as caches

79

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

80

(superclass persistent-class))

81

t)

82

(defmethod c2mop:validate-superclass ((subclass cached-persistent-class)

83

(superclass standard-class))

84

t)

85

(defmethod c2mop:validate-superclass ((subclass cached-persistent-class)

86

(superclass cached-class))

87

t)

88

(defmethod c2mop:validate-superclass ((subclass cached-persistent-class)

89

(superclass persistent-class))

90

t))

91

92

93

94

(defclass identified-object ()

95

((identifier

96

;; :initarg :id this is used for things like repository <account>/<name> id values

97

:initarg :identifier

98

;; no initform: initialize-instance computes it as required

99

:reader object-identifier :reader instance-identifier

100

:writer setf-instance-identifier

101

:documentation

102

"The global internal identifier for site-global persistent metadata.

103

The site can be a single host, in which case the value would be identical to a resource

104

uri, or it can, instead, reflect an installation name, in which case a

105

value is shared across all hosts which constitute the site.

106

The id combines the installation site, account, and repository names and is unique within

107

the installation. This may not always identical with either the

108

repository-uri, as that would be specific to an individual host within a multi-host

109

installation, or with any request uri which identifies the object as a resource to an http

110

      server as those things reflect the namespaces of the request interface rather than the internal

111

namespace managed by the store.

112

It is used for comparisons to persisted and autheorization data.

113

If the value is not provided at initialization, it is computed for the

114

instance on demand."))

115

(:documentation

116

    "The abstract root class for for data which can be associated with a persistent resource binds just

117

the identifier, but none of the meta-data to manager persistence."))

118

119

(deftype persistent-object-state () '(member :clean :deleted :dirty :hollow :new :detached))

120

121

(defclass persistent-object (identified-object)

122

((state

123

:initform :hollow :accessor instance-state

124

:type persistent-object-state

125

:documentation

126

"Indicates the state of the resource instance wrt the last merge from store.

127

Allows one of :hollow, :dirty :clean :new :deleted nil

128

If set to nil, implicit read/write operations for synchronization are suppressed")

129

(store-repository-id

130

:initform nil :initarg :store-repository-id

131

:reader get-resource-store-repository-id :writer (setf resource-store-repository-id)

132

:documentation

133

"Specify the store which backs the instance.")

134

(store-revision

135

:initform nil :accessor instance-store-revision

136

:type (or null integer)

137

:documentation

138

"Indicates the state of the store itself, in the form of the revision identifier

139

current for the instance's repository at the point where the instance was last read.")

140

(store-graph

141

:initform nil :reader get-instance-store-graph

142

:writer setf-instance-store-graph

143

:documentation

144

"Caches the resource-specific graph as present in the field which was merged from the store

145

when reading the resource or written to the store when updating."))

146

(:metaclass persistent-class))

147

148

(defclass persistent-graph-object (persistent-object)

149

()

150

(:metaclass persistent-class))

151

(defclass persistent-graph-subject-object (persistent-object)

152

()

153

(:metaclass persistent-class))

154

(defclass persistent-subject-object (persistent-object)

155

()

156

(:metaclass persistent-class))

157

158

159

(defclass cached-object (identified-object)

160

()

161

(:metaclass cached-class))

162

163

(defclass cached-persistent-object (cached-object persistent-object)

164

()

165

(:metaclass cached-persistent-class))

166

167

(defclass cached-persistent-graph-object (persistent-graph-object cached-persistent-object)

168

()

169

(:metaclass persistent-class))

170

(defclass cached-persistent-graph-subject-object (persistent-graph-subject-object cached-persistent-object)

171

()

172

(:metaclass persistent-class))

173

(defclass cached-persistent-subject-object (persistent-subject-object cached-persistent-object)

174

()

175

(:metaclass persistent-class))

176

177

178

(defclass described-object (persistent-object)

179

((predicates

180

:initform ()

181

     #+(or) '(|acl|:|accessTo| |acl|:|agent| |acl|:|agentClass| |acl|:|mode| |rdf|:|type| |sioc|:|ip_address|)

182

:allocation :class

183

:reader instance-predicates))

184

(:metaclass persistent-class)

185

(:documentation

186

    "A described object is a persistent object for which the fields exchanged with the store constitute

187

     (excerpts from) a concise bounded description, rather than just a sequence of statements  with a common

188

subject.

189

It adds the predicate slot which, if bound to a set of properties, will

190

limit the description to those properties."))

191

192

193

(defclass persistent-class-slot-definition ()

194

((store-property

195

:initform nil :initarg :store-property

196

:accessor slot-definition-store-property

197

:documentation "The statement property recognized when decoding a graph and

198

generated when encoding a graph for reading and committing to the store.")

199

(encode-presentation-property

200

:initform nil :initarg :encode-presentation-property

201

:accessor slot-definition-encode-presentation-property

202

:documentation "The statement property generated when encoding a graph for

203

presentation.")

204

(decode-presentation-property

205

:initform nil :initarg :decode-presentation-property

206

:accessor slot-definition-decode-presentation-property

207

:documentation "The statement property recognized when decoding a graph from

208

a presentation."))

209

(:documentation "Mix-in additional slot attributes to specify the property terms respective

210

the given slot for data exchanges with the store and with the ui."))

211

212

(defmethod slot-definition-store-property ((sd t)) nil)

213

(defmethod slot-definition-encode-presentation-property ((sd t)) nil)

214

(defmethod slot-definition-decode-presentation-property ((sd t)) nil)

215

216

(defun persistent-class-slot-definition-p (datum)

217

(typep datum 'persistent-class-slot-definition))

218

219

(defclass persistent-class-direct-slot-definition (persistent-class-slot-definition

220

                                                    c2mop:standard-direct-slot-definition)

221

()

222

(:documentation "Mix persistent slot attributes into direct slot definitions."))

223

224

(defclass persistent-class-effective-slot-definition (persistent-class-slot-definition

225

                                                       c2mop:standard-effective-slot-definition)

226

((writer :accessor slot-definition-writer)

227

(reader :accessor slot-definition-reader))

228

(:documentation "Mix persistent slot attributes into effective slot definitions.

229

Add cached values for a single reader and a single writer functions for use when enxchanging

230

adaa with the store."))

231

232

(defmethod c2mop:direct-slot-definition-class ((class persistent-class) &key &allow-other-keys)

233

'persistent-class-direct-slot-definition)

234

235

(defmethod c2mop:effective-slot-definition-class ((class persistent-class) &key property store-property

236

                                                   encode-presentation-property decode-presentation-property

237

&allow-other-keys)

238

"Make specialization contingent on the presence of requisite initargs."

239

(if (or property

240

store-property

241

encode-presentation-property

242

decode-presentation-property)

243

'persistent-class-effective-slot-definition

244

(call-next-method)))

245

246

#+sbcl

247

(defmethod sb-pcl::compute-effective-slot-definition-initargs ((class persistent-class) direct-sds)

248

(let ((store-property (some #'slot-definition-store-property direct-sds))

249

(encode-presentation-property (some #'slot-definition-encode-presentation-property direct-sds))

250

(decode-presentation-property (some #'slot-definition-decode-presentation-property direct-sds)))

251

(append (when store-property `(:store-property ,store-property))

252

             (when encode-presentation-property `(:encode-presentation-property ,encode-presentation-property))

253

             (when decode-presentation-property `(:decode-presentation-property ,decode-presentation-property))

254

(call-next-method))))

255

256

257

258

259

(defmethod initialize-instance ((instance persistent-class-direct-slot-definition) &rest initargs

260

&key property

261

(store-property property)

262

(presentation-property property)

263

(encode-presentation-property presentation-property)

264

(decode-presentation-property presentation-property))

265

(apply #'call-next-method instance

266

:store-property store-property

267

:encode-presentation-property encode-presentation-property

268

:decode-presentation-property decode-presentation-property

269

initargs))

270

271

272

 (defmethod c2mop:compute-effective-slot-definition ((class persistent-class) (slot-name t) direct-slot-definitions)

273

(let ((sd (call-next-method)))

274

(when (typep sd 'persistent-class-slot-definition)

275

;; rdf-specific slot definition fields

276

       (setf (slot-definition-store-property sd) (some #'slot-definition-store-property direct-slot-definitions))

277

       (setf (slot-definition-encode-presentation-property sd) (some #'slot-definition-encode-presentation-property direct-slot-definitions))

278

       (setf (slot-definition-decode-presentation-property sd) (some #'slot-definition-decode-presentation-property direct-slot-definitions))

279

       ;; cache one reader/writer; leave in symbolic form as the functions may not have yet been defined

280

       (setf (slot-definition-reader sd) (first (some #'c2mop:slot-definition-readers direct-slot-definitions)))

281

       (setf (slot-definition-writer sd) (first (some #'c2mop:slot-definition-writers direct-slot-definitions))))

282

sd))

283

284

(defgeneric compute-instance-identifier (instance)

285

(:method ((instance identified-object))

286

"the default method knows no identifier"

287

nil))

288

289

(defmethod initialize-instance ((instance identified-object) &key)

290

(call-next-method)

291

(unless (cond ((slot-boundp instance 'identifier)

292

(with-slots (identifier) instance

293

(typecase identifier

294

(iri identifier)

295

(string (setf-instance-identifier (intern-iri identifier) instance))

296

(null nil)

297

(t (log-warn "anomalous identifier: ~a: ~s"

298

                                   (with-output-to-string (stream) (print-unreadable-object (instance stream :identity t :type t)))

299

identifier)

300

nil)))))

301

(setf-instance-identifier (compute-instance-identifier instance) instance)))

302

303

;;;

304

305

(defgeneric make-persistent-instance (class &rest initargs)

306

(:documentation "make a new persistent insance by delegating to make-instance.

307

this in order to ensure that any default values and initial state is bound.")

308

(:method ((class symbol) &rest args)

309

(declare (dynamic-extent args))

310

(apply #'make-persistent-instance (find-class class) args))

311

(:method ((class persistent-class) &rest args)

312

(declare (dynamic-extent args))

313

(apply #'make-instance class args)))

314

315

(defgeneric make-synchronized-instance (class &rest initargs)

316

(:documentation "Create a new instance of the given class and read the

317

initial state from the store. The base constructor is make- variant, rather

318

than an allocate-variant")

319

(:method ((class t) &rest initargs)

320

(declare (dynamic-extent initargs))

321

(read-resource (apply #'make-persistent-instance class initargs))))

322

323

(defgeneric instance-graph-identifier (resource)

324

(:method ((instance identified-object))

325

(instance-identifier instance)))

326

327

(defgeneric instance-repository-id (persistent-instance)

328

(:method ((instance persistent-object))

329

(resource-store-repository-id instance)))

330

331

(defgeneric instance-repository (persistent-instance)

332

(:method ((instance persistent-object))

333

(repository (instance-repository-id instance))))

334

335

(defgeneric resource-store-repository-id (persistent-instance)

336

(:method ((instance persistent-object))

337

(or (get-resource-store-repository-id instance)

338

(setf (resource-store-repository-id instance)

339

(compute-resource-store-repository-id instance)))))

340

341

(defgeneric compute-resource-store-repository-id (persistent-instance)

342

(:documentation

343

"Compute the persistent store for a new persistent instance from its state.

344

This allows an instance-specific, inherent repository for backing store."))

345

346

(defgeneric compute-class-instance-identifier (class initargs)

347

(:method ((class class) (initargs list))

348

(or (getf initargs :identifier)

349

(getf initargs :id))))

350

351

(defgeneric ensure-instance (class &rest initargs)

352

(:method ((designator symbol) &rest initargs)

353

(declare (dynamic-extent initargs))

354

(apply #'ensure-instance (find-class designator) initargs))

355

(:method ((class class) &rest initargs)

356

(declare (dynamic-extent initargs))

357

(apply #'make-instance class initargs))

358

(:method ((class cached-class) &rest initargs)

359

(declare (dynamic-extent initargs))

360

(let* ((identifier (compute-class-instance-identifier class initargs))

361

(existing-instance (get-registry identifier (class-cache class))))

362

(cond (existing-instance

363

(unless (eq (type-of existing-instance) (class-name class))

364

(change-class existing-instance class))

365

(values (if initargs

366

(apply #'reinitialize-instance existing-instance initargs)

367

existing-instance)

368

t))

369

(t

370

(apply #'make-instance class initargs))))))

371

372

(defmethod make-instance ((class cached-class) &key)

373

"Register each new instance - replacing any existing one."

374

(register-instance class (call-next-method)))

375

376

(defgeneric register-instance (context instance)

377

(:documentation "register the given instance relative to the context class -

378

likely the class hierarchy and returnt the instance.")

379

(:method ((class cached-class) (instance cached-object))

380

(setf (get-registry (instance-identifier instance) (class-cache class))

381

instance)))

382

383

(defgeneric unregister-instance (context instance)

384

(:documentation "register the given instance relative to the context class -

385

likely the class hierarchy and returnt the instance.")

386

(:method ((class cached-class) (instance cached-object))

387

(rem-registry (instance-identifier instance) (class-cache class))))

388

389

;;;

390

;;; administer instance state wrt the store

391

392

(defgeneric resource-clean-p (resource)

393

(:method ((resource persistent-object))

394

(eq (instance-state resource) :clean)))

395

396

(defgeneric resource-deleted-p (resource)

397

(:documentation

398

"Return true if the instance has been marked for deletion since the last store synchronization.")

399

(:method ((resource persistent-object))

400

(eq (instance-state resource) :deleted)))

401

402

(defgeneric resource-detached-p (resource)

403

(:documentation

404

"Return true if the instance has been detached from the store.

405

This means that i remains as is, independent store changes")

406

(:method ((resource persistent-object))

407

(eq (instance-state resource) :detached)))

408

409

(defgeneric resource-dirty-p (resource)

410

(:documentation

411

    "Return true if the instance's attributes have been modified since the last store synchronization.")

412

(:method ((resource persistent-object))

413

(eq (instance-state resource) :dirty)))

414

415

(defgeneric resource-hollow-p (resource)

416

(:documentation

417

"Return true if the instance has been neither synchronized nor modified.")

418

(:method ((resource persistent-object))

419

(eq (instance-state resource) :hollow)))

420

421

(defgeneric resource-new-p (resource)

422

(:documentation

423

"Return true if the resource contains data which has never been persisted. That is, it has been

424

created and modified, but it is not present in the store, as it is not yet synchronized.")

425

(:method ((resource persistent-object))

426

(eq (instance-state resource) :new)))

427

428

(defgeneric resource-synchronized-p (resource)

429

(:documentation

430

"Return true if the resource state in unmodified since the latest merge to-or-from the store.

431

The reference revision is the store repository's last write revision,")

432

(:method ((resource t))

433

t)

434

(:method ((resource persistent-object))

435

(case (instance-state resource)

436

((:clean :new)

437

(let ((instance-revision (instance-store-revision resource))

438

(repository-revision (repository-last-revision (instance-repository-id resource))))

439

(values (equalp instance-revision repository-revision) repository-revision)))

440

(:detached

441

t)

442

(t

443

nil))))

444

445

;;;

446

;;;

447

448

(:documentation "codec operators"

449

"manage a class' metadata about persistent slots and coding/decoding operators by checking

450

slot definition class and the function signature and the presence of the name

451

in the respective package for presenation and store operators.")

452

453

(defgeneric presentation-reader-p (function)

454

(:method ((method standard-method))

455

(presentation-reader-p (c2mop:method-generic-function method)))

456

(:method ((function standard-generic-function))

457

(and (= 1 (length (c2mop:generic-function-lambda-list function)))

458

(presentation-reader-p (c2mop:generic-function-name function))))

459

(:method ((name cons))

460

nil)

461

(:method ((name symbol))

462

(find-symbol (symbol-name name) *presentation-codec-package*)))

463

464

(defgeneric presentation-writer-p (function)

465

(:method ((method standard-method))

466

(presentation-writer-p (c2mop:method-generic-function method)))

467

(:method ((function standard-generic-function))

468

(and (= 2 (length (c2mop:generic-function-lambda-list function)))

469

(presentation-writer-p (c2mop:generic-function-name function))))

470

(:method ((name cons))

471

(and (eq (first name) 'setf) (presentation-writer-p (second name))))

472

(:method ((name symbol))

473

(find-symbol (symbol-name name) *presentation-codec-package*)))

474

475

476

(defgeneric store-reader-p (function)

477

(:method ((method standard-method))

478

(store-reader-p (c2mop:method-generic-function method)))

479

(:method ((function standard-generic-function))

480

(and (= 1 (length (c2mop:generic-function-lambda-list function)))

481

(store-reader-p (c2mop:generic-function-name function))))

482

(:method ((name cons))

483

nil)

484

(:method ((name symbol))

485

(find-symbol (symbol-name name) *store-codec-package*)))

486

487

(defgeneric store-writer-p (function)

488

(:method ((method standard-method))

489

(store-writer-p (c2mop:method-generic-function method)))

490

(:method ((function standard-generic-function))

491

(and (= 2 (length (c2mop:generic-function-lambda-list function)))

492

(store-writer-p (c2mop:generic-function-name function))))

493

(:method ((name cons))

494

(and (eq (first name) 'setf) (store-writer-p (second name))))

495

(:method ((name symbol))

496

(find-symbol (symbol-name name) *store-codec-package*)))

497

498

499

(defgeneric method-property (method)

500

(:method ((method standard-method))

501

(method-property (c2mop:method-generic-function method)))

502

(:method ((function standard-generic-function))

503

(method-property (c2mop:generic-function-name function)))

504

(:method ((name cons))

505

(second name))

506

(:method ((name symbol))

507

name))

508

509

510

(defgeneric class-presentation-readers (object)

511

(:method ((object persistent-object))

512

(class-presentation-readers (class-of object)))

513

(:method ((class persistent-class))

514

(if (slot-boundp class 'presentation-readers)

515

(slot-value class 'presentation-readers)

516

(setf (slot-value class 'presentation-readers)

517

(remove-duplicates (loop for class in (c2mop:class-precedence-list class)

518

                                      append (loop for method in (c2mop:specializer-direct-methods class)

519

                                                   for function = (c2mop:method-generic-function method)

520

                                                   when (presentation-reader-p function)

521

                                                   collect function)))))))

522

523

(defgeneric class-presentation-writers (object)

524

(:method ((object persistent-object))

525

(class-presentation-writers (class-of object)))

526

(:method ((class standard-class))

527

(if (slot-boundp class 'presentation-writers)

528

(slot-value class 'presentation-writers)

529

(setf (slot-value class 'presentation-writers)

530

(remove-duplicates (loop for class in (c2mop:class-precedence-list class)

531

                                      append (loop for method in (c2mop:specializer-direct-methods class)

532

                                                   for function = (c2mop:method-generic-function method)

533

                                                   when (presentation-writer-p function)

534

                                                   collect function)))))))

535

536

(defgeneric class-store-readers (object)

537

(:method ((object persistent-object))

538

(class-store-readers (class-of object)))

539

(:method ((class persistent-class))

540

(if (slot-boundp class 'store-readers)

541

(slot-value class 'store-readers)

542

(setf (slot-value class 'store-readers)

543

(remove-duplicates (loop for class in (c2mop:class-precedence-list class)

544

                                      append (loop for method in (c2mop:specializer-direct-methods class)

545

                                                   for function = (c2mop:method-generic-function method)

546

                                                   when (store-reader-p function)

547

                                                   collect function)))))))

548

549

(defgeneric class-store-writers (object)

550

(:method ((object persistent-object))

551

(class-store-writers (class-of object)))

552

(:method ((class standard-class))

553

(if (slot-boundp class 'store-writers)

554

(slot-value class 'store-writers)

555

(setf (slot-value class 'store-writers)

556

(remove-duplicates (loop for class in (c2mop:class-precedence-list class)

557

                                      append (loop for method in (c2mop:specializer-direct-methods class)

558

                                                   for function = (c2mop:method-generic-function method)

559

                                                   when (store-writer-p function)

560

                                                   collect function)))))))

561

562

(defgeneric class-persistent-slots (class)

563

(:method ((class persistent-class))

564

(or (get-class-persistent-slots class)

565

(setf-class-persistent-slots (compute-class-persistent-slots class) class)))

566

567

(:method ((object persistent-object))

568

(class-persistent-slots (class-of object))))

569

570

571

(defgeneric compute-class-persistent-slots (class)

572

(:method ((class persistent-class))

573

(loop for sd in (c2mop:class-slots (c2mop:ensure-finalized class))

574

when (persistent-class-slot-definition-p sd)

575

collect sd)))

576

577

578

579

;;; the graph and presentation implementation are identical at the code, but

580

;;; constrain based on different packages and would generate different

581

;;; implementation for the respective projections

582

583

#+(or)

584

(defgeneric encode-presentation (resource)

585

(:documentation "convert a resource into the respective statement sequence

586

for projection as a request response. Govern the constitution according to

587

the readers visible in the 'presentation-codec' package.

588

The base method either interprets, or if the class supports compilation,

589

generates a class specific method and delegates to it. (NYI)")

590

591

(:method ((resource standard-object))

592

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

593

(slot-definitions (class-persistent-slots class))

594

(identifier (instance-identifier resource)))

595

(loop for sd in slot-definitions

596

for reader = (some #'presentation-reader-p (c2mop:slot-definition-readers sd))

597

when reader

598

collect `(,identifier

599

,(some #'iri-p (c2mop:slot-definition-initargs sd))

600

,(funcall reader resource))))))

601

602

(defgeneric encode-presentation-graph (resource)

603

(:documentation "convert a resource into the respective statement sequence

604

for projection as a request response. Govern the constitution according to

605

the readers visible in the 'presentation-codec' package.

606

The base method either interprets, or if the class supports compilation,

607

generates a class specific method and delegates to it. (NYI)")

608

609

(:method ((resource standard-object))

610

(let* ((identifier (instance-identifier resource))

611

(slot-definitions (class-persistent-slots (class-of resource))))

612

(loop for sd in slot-definitions

613

for reader = (slot-definition-reader sd)

614

for property = (slot-definition-encode-presentation-property sd)

615

for boundp = (slot-boundp resource (c2mop:slot-definition-name sd))

616

;; do (print (list reader property boundp))

617

when (and reader property boundp)

618

collect (let ((object (funcall (fdefinition reader) resource)))

619

`(,identifier ,property ,(case object

620

                                                  ((t) spocq.a:|true|)

621

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

622

(t object))))))))

623

624

625

626

(defgeneric decode-presentation-graph (resource graph)

627

(:documentation "Given a resource and the intended content encoded as a graph

628

- that is, as a list of statements, project the respective statement value

629

into the resource. Govern the operation according to

630

the writers visible in the 'presentation-codec' package.

631

The base method either interprets, or if the class supports compilation,

632

generates a class specific method and delegates to it. (NYI)")

633

634

(:method ((resource persistent-object) (graph list))

635

(ecase *decode-presentation-graph.mode*

636

(:eval

637

(let* ((identifier (instance-identifier resource))

638

(slot-definitions (class-persistent-slots (class-of resource)))

639

(new-state (instance-state resource)))

640

          (loop for (subject predicate object) in graph          ; presentation produces a triple field

641

                for sd = (find predicate slot-definitions :key #'slot-definition-decode-presentation-property)

642

for writer = (when sd (slot-definition-writer sd))

643

when (and writer (equalp subject identifier))

644

do (progn (when (equal object "") (setf object nil))

645

;; rdf:nil remains as the indication to unbind

646

(when *decode-presentation-graph.verbose*

647

(format *trace-output* "~%d-p-g: ~a: ~s: ~s ~s"

648

identifier writer predicate object))

649

(funcall (fdefinition writer) object resource)

650

;; account for detached state

651

(when new-state (setf new-state :dirty))))

652

(when (and *decode-presentation-graph.verbose* (not (eq new-state :dirty)))

653

(warn "no change to resource: ~s ~%~s" resource graph))

654

(setf (instance-state resource) new-state)

655

resource))

656

(:compile

657

(let* ((slot-definitions (class-persistent-slots (class-of resource)))

658

(method-lambda `(lambda (resource graph)

659

(let ((identifier (instance-identifier resource))

660

(new-state (instance-state resource)))

661

                                     (loop for (subject predicate object) in graph

662

                                           when (equalp subject identifier)

663

do (case predicate

664

                                                ,@(loop for sd in slot-definitions

665

                                                        for property = (slot-definition-decode-presentation-property sd)

666

                                                        for writer = (slot-definition-writer sd)

667

                                                        when (and property writer)

668

                                                        collect `(,property (when new-state (setf new-state :dirty))

669

                                                                            (funcall ,(fdefinition writer) object resource)))))

670

(setf (instance-state resource) new-state))

671

resource)))

672

(eval `(defmethod decode-presentation-graph ((resource ,(type-of resource)) (graph list))

673

,@(cddr method-lambda)))

674

(decode-presentation-graph resource graph))))))

675

676

677

#+(or)

678

(defgeneric encode-persistent-graph (resource)

679

(:documentation "Convert a resource into the respective statement sequence

680

for projection as a request response. Govern the constitution according to

681

the readers visible in the 'persistence-codec' package.

682

The base method either interprets, or if the class supports compilation,

683

generates a class specific method and delegates to it. (NYI)")

684

685

(:method ((resource persistent-object))

686

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

687

(slot-definitions (class-persistent-slots class))

688

(identifier (instance-identifier resource)))

689

(loop for sd in slot-definitions

690

for reader = (some #'store-reader-p (c2mop:slot-definition-readers sd))

691

when reader

692

collect `(,identifier

693

,(some #'iri-p (c2mop:slot-definition-initargs sd))

694

,(funcall reader resource))))))

695

696

(defgeneric (setf instance-store-graph) (graph resource)

697

(:method ((graph list) (resource persistent-object))

698

(setf (instance-state resource)

699

(ecase (instance-state resource)

700

((:clean :deleted :dirty) :dirty)

701

;; it is hollow, that this operator presumes a new instance

702

((:hollow :new) :new)

703

(:detached :detached)))

704

(setf-instance-store-graph graph resource)))

705

706

(defgeneric instance-graph-identifier (resource)

707

(:documentation "return the graph to contain assertions about the resource.

708

The default method indicates all graphs which specializations cann limit this

709

to a specific graph, for example that of the resource identifier.")

710

(:method ((instance persistent-object))

711

|urn:dydra|:|all|))

712

713

(defgeneric instance-store-graph (resource)

714

(:method ((resource persistent-object))

715

(synchronize-resource resource)

716

(get-instance-store-graph resource)))

717

718

(defgeneric encode-store-graph (resource)

719

(:documentation "Convert a resource into the respective statement sequence

720

for projection as a request response. Govern the constitution according to

721

the readers visible in the 'persistence-codec' package.

722

The base method either interprets, or if the class supports compilation,

723

generates a class specific method and delegates to it. (NYI)")

724

725

(:method ((resource standard-object))

726

(let* ((identifier (instance-identifier resource))

727

(graph-identifier (instance-graph-identifier resource))

728

(slot-definitions (class-persistent-slots (class-of resource))))

729

(flet ((normalize (object)

730

(case object

731

((t) spocq.a:|true|)

732

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

733

(t object))))

734

(loop for sd in slot-definitions

735

for reader = (slot-definition-reader sd)

736

for property = (slot-definition-store-property sd)

737

for boundp = (slot-boundp resource (c2mop:slot-definition-name sd))

738

when (and reader property boundp)

739

               collect `(spocq.a:|quad| ,identifier ,property ,(normalize (funcall (fdefinition reader) resource)) ,graph-identifier))))))

740

#+(or)

741

(defmethod encode-store-graph :before ((resource t))

742

(describe resource))

743

744

(defgeneric decode-store-graph (resource graph)

745

(:documentation

746

"Given a resource and the intended content encoded as a graph

747

- that is, as a list of statements, project the respective statement values

748

into the resource.

749

Govern the operation according to the writers visible in the 'persistence-codec' package.

750

The base method either interprets, or if the class supports compilation,

751

generates a class specific method and delegates to it.

752

Specilizations can provide :around and/or :after methods can constrain state.")

753

754

(:method ((resource persistent-object) (graph list))

755

;;(print :before)

756

;; (describe resource)

757

(ecase *decode-store-graph.mode*

758

(:eval

759

(let* ((identifier (instance-identifier resource))

760

(slot-definitions (class-persistent-slots (class-of resource)))

761

;;(new-graph ())

762

)

763

(loop for statement in graph ; store produces a quad field

764

for (nil subject predicate object) = statement

765

when (equalp subject identifier)

766

                do (let* ((sd (find predicate slot-definitions :key #'slot-definition-store-property))

767

(writer (when sd (slot-definition-writer sd))))

768

; do (print (list (list subject predicate object) sd writer))

769

;;(push statement new-graph)

770

(when writer

771

                       (funcall (fdefinition writer) (compute-cspo-term-value object graph) resource))))

772

;; (setf-instance-store-graph new-graph resource)

773

(setf-instance-store-graph graph resource))

774

;(describe resource)

775

resource)

776

(:compile

777

(let ((method-lambda (compute-decode-store-graph-lambda (class-of resource))))

778

(eval `(defmethod decode-store-graph ((resource ,(type-of resource)) (graph list))

779

,@(cddr method-lambda)))

780

(decode-store-graph resource graph))))

781

782

#+(or)

783

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

784

(slot-definitions (class-persistent-slots class))

785

(identifier (instance-identifier resource)))

786

(loop for (nil subject predicate object) in graph

787

for sd = (loop for sd in slot-definitions

788

                            for slot-property = (some #'iri-p (c2mop:slot-definition-initargs sd))

789

when (equalp slot-property predicate)

790

return sd)

791

for writer = (when sd (some #'store-writer-p (c2mop:slot-definition-writers sd)))

792

when (and writer (equalp subject identifier))

793

do (funcall writer object resource)))))

794

795

(defgeneric compute-decode-store-graph-lambda (class)

796

(:method ((class symbol))

797

(compute-decode-store-graph-lambda (find-class class)))

798

(:method ((class persistent-class))

799

(let ((slot-definitions (class-persistent-slots class)))

800

`(lambda (resource graph)

801

(let ((identifier (instance-identifier resource))

802

(new-graph ()))

803

(loop for statement in graph

804

for (nil subject predicate object) = statement

805

when (equalp subject identifier)

806

do (case predicate

807

,@(loop for sd in slot-definitions

808

for property = (slot-definition-store-property sd)

809

for writer = (slot-definition-writer sd)

810

when (and property writer)

811

collect `(,property (funcall ,(fdefinition writer) object resource)

812

(push statement new-graph)))))

813

(setf-instance-store-graph new-graph resource))

814

resource))))

815

816

(defgeneric compute-decode-ui-graph-lambda (class)

817

(:method ((class symbol))

818

(compute-decode-store-graph-lambda (find-class class)))

819

(:method ((class persistent-class))

820

(let ((slot-definitions (class-persistent-slots class)))

821

`(lambda (resource graph)

822

(let ((identifier (instance-identifier resource))

823

(new-graph ()))

824

(loop for statement in graph

825

for (subject predicate object) = statement

826

when (equalp subject identifier)

827

do (case predicate

828

,@(loop for sd in slot-definitions

829

for property = (slot-definition-store-property sd)

830

for writer = (slot-definition-writer sd)

831

when (and property writer)

832

collect `(,property (funcall ,(fdefinition writer) object resource)

833

(push statement new-graph)))))

834

(setf (resource-ui-graph resource) new-graph))

835

resource))))

836

837

838

(:documentation "term -> value conversion"

839

"Compute the value which corresponds to data from the store.

840

This involves transforming a graph field (or a subset of the statements) into an instance,

841

decoding lists, and converting atomic term values.

842

    Two field types are supported, (c s p o), for data from the store and (s p o), for data from the ui.

843

844

    The primary interface is the respective compute-*-term-value operator. It accepts a term and the cbd field.

845

The operator combines the term with the field in one of three ways:

846

    - if the term is the subject of a typed resource, in which case, it delegated to compute-*-term-instance

847

and returns the described instance.

848

    - if the term is the head of a pair, in which case it delegates to compute-*-term-list returns the

849

described list.

850

- otherwise, for a literal term, it returns the value unchanged.

851

852

    The secondary interface is the respective merge-*-term-value. It accepts the term and the paired addition

853

and deletion fields emitted from the store as a the CRDT notification from an update operation.

854

855

    The compute—*-term-instance operators check the subject term against a cache to see whether the instance

856

    is already present. If so, then if the field revision id matches, the iri is a reference to the existing

857

    state and the result is the unmodified cached instance. If the revision id does not match, then the

858

existing instance is cleared and reinitialized with the new state.

859

860

The merge-*-term-instance operators perform a similar check, aan modify know instances.

861

    In the normal case, an iri identifies a known instance and the store revision id indicates that its state

862

    has change since the most recent synchronization. In that case the +/- fields are merged into the instance,

863

    whereby those deletions which are not also reflected as additions cause a slot to be unbound all other

864

    changes are effected by on the basis of additions, which requires any list values to be modified in their

865

    entirety. If no instance exists, then the operation has no effect. Given a known instance, if the revision

866

id matches, then it is returned unmodified. but a revision change causes the +/-")

867

868

869

(defun compute-cspo-term-value (term statements)

870

"Given a subject term and a statement field, compute the model value, which may be an instance

871

or a list of values."

872

(typecase term

873

((or spocq:blank-node iri)

874

(flet ((get-property (test-property)

875

(loop for (nil subject property object) in statements

876

when (and (equalp subject term) (equalp property test-property))

877

return object)))

878

(let* ((type (get-property |rdf|:|type|)))

879

(cond ((and type (symbolp type))

880

(compute-cspo-term-instance term

881

(or (find-class type nil)

882

                                                  (error "Invalid type in library resource graph: ~s" type))

883

statements))

884

((get-property |rdf|:|first|)

885

(compute-cspo-term-list term statements))

886

(t

887

term)))))

888

(t

889

term)))

890

891

(defun compute-cspo-term-instance (term class statements)

892

"Given a subject term, the respective class and a statement field, compute the model instance

893

- correllate the field's statements with slot definitions

894

- construct the value respective each slot definition

895

- accumulate the values and initargs as an initialization list

896

- create the instance with the constructed initargs "

897

(let ((slot-definitions (class-persistent-slots class))

898

(initargs ()))

899

(loop for (nil subject property object) in statements

900

for sd = (when (equalp subject term)

901

(loop for sd in slot-definitions

902

if (equalp property (slot-definition-decode-presentation-property sd))

903

do (return sd)))

904

if sd

905

do (let ((value (compute-cspo-term-value object statements))

906

(type (sb-mop:slot-definition-type sd)))

907

            (when type (assert (typep value type) () "invalid property value: ~s: ~s." property value))

908

(setf (getf initargs (first (c2mop:slot-definition-initargs sd))) value))

909

else do (unless (member property '(|rdf|:|type| |rdf|:|first| |rdf|:|rest|

910

                                                  |http://www.w3.org/2000/01/rdf-schema#|:|subClassOf|

911

                                                  |http://www.w3.org/2000/01/rdf-schema#|:|comment|

912

                                                  |http://www.w3.org/2000/01/rdf-schema#|:|label|))

913

(log-warn "Unsupported property: ~s: ~s." class property)))

914

(apply #'ensure-instance class :identifier term initargs)))

915

916

(defun compute-cspo-term-list (term statements)

917

   "given a graph as a list of statements and the term for the list head, compute the list of objects."

918

(if (eq term |rdf|:|nil|)

919

()

920

(loop with first = nil

921

with rest = nil

922

for (nil subject predicate object) in statements

923

when (equal term subject)

924

do (case predicate

925

(|rdf|:|first|

926

(assert (null first) () "duplicate first in list graph: ~s" statements)

927

(setf first (compute-cspo-term-value object statements)))

928

(|rdf|:|rest|

929

(assert (null rest) () "duplicate rest in list graph: ~s" statements)

930

(setf rest (compute-cspo-term-value object statements)))

931

(t

932

(error "invalid predicate in list graph: ~s: ~s" predicate statements)))

933

when (and first rest)

934

return (cons first (compute-cspo-term-list rest statements))

935

finally (error "head not in list graph: ~s: ~s" term statements))))

936

 ;;; (compute-cspo-term-list <_:a> '((<_:a> |rdf|:|first| 1) (<_:a> |rdf|:|rest| <_:b>) (<_:b> |rdf|:|first| 2) (<_:b> |rdf|:|rest| |rdf|:|nil|)))

937

938

939

;;; extract a single resource value from a triple graph

940

941

(defun compute-spo-term-value (term statements)

942

(typecase term

943

((or spocq:blank-node iri)

944

(flet ((get-property (test-property)

945

(loop for (subject property object) in statements

946

when (and (equalp subject term) (equalp property test-property))

947

return object)))

948

(let* ((type (get-property |rdf|:|type|)))

949

(cond ((and type (symbolp type))

950

(compute-spo-term-instance term

951

(or (find-class type nil)

952

                                                  (error "Invalid type in library resource graph: ~s" type))

953

statements))

954

((get-property |rdf|:|first|)

955

(compute-spo-term-list term statements))

956

(t

957

term)))))

958

(t

959

term)))

960

961

962

(defun compute-spo-term-instance (term class statements)

963

;; extract the instance from the graph

964

(let ((slot-definitions (class-persistent-slots class))

965

(initargs ()))

966

(loop for (subject property object) in statements

967

when (equalp subject term)

968

do (let ((sd (loop for sd in slot-definitions

969

                              if (equalp property (slot-definition-decode-presentation-property sd))

970

do (return sd))))

971

(if sd

972

(let ((value (compute-spo-term-value object statements))

973

(type (sb-mop:slot-definition-type sd)))

974

#+(or)

975

(print (list property

976

(c2mop:slot-definition-name sd)

977

(first (c2mop:slot-definition-initargs sd))

978

value))

979

                    (when type (assert (typep value type) () "invalid property value: ~s: ~s." property value))

980

(setf (getf initargs (first (c2mop:slot-definition-initargs sd))) value))

981

(unless (member property '(|rdf|:|type| |rdf|:|first| |rdf|:|rest|

982

                                             |http://www.w3.org/2000/01/rdf-schema#|:|subClassOf|

983

                                             |http://www.w3.org/2000/01/rdf-schema#|:|comment|

984

                                             |http://www.w3.org/2000/01/rdf-schema#|:|label|))

985

(log-warn "Unsupported property: ~s: ~s." class property)))))

986

(apply #'ensure-instance class :identifier term initargs)))

987

988

(defun compute-spo-term-list (term statements)

989

   "Given a graph as a list of statements and the term for the list head, compute the list of values."

990

(if (eq term |rdf|:|nil|)

991

()

992

(loop with first = nil

993

with rest = nil

994

for (nil subject predicate object) in statements

995

when (equal term subject)

996

do (case predicate

997

(|rdf|:|first|

998

(assert (null first) () "duplicate first in list graph: ~s" statements)

999

(setf first (compute-spo-term-value object statements)))

1000

(|rdf|:|rest|

1001

(assert (null rest) () "duplicate rest in list graph: ~s" statements)

1002

(setf rest (compute-spo-term-value object statements)))

1003

(t

1004

(error "invalid predicate in list graph: ~s: ~s" predicate statements)))

1005

when (and first rest)

1006

return (cons first (compute-spo-term-list rest statements))

1007

finally (error "head not in list graph: ~s: ~s" term statements))))

1008

1009

1010

(defun repository-match-cbd (transaction context subject slots)

1011

   "Project the concise bounded description of a resource from a given store graph into a model instance.

1012

This walks the description graph from the resource identifier, through all predicates

1013

for which slots are defined, to collect the description of all sub-resources."

1014

1015

(let* ((field (repository-match-field transaction context '?::s '?::p '?::o)))

1016

;; given the complete field, construct the cbd, subject to the given predicates

1017

(let ((description ())

1018

(terms ()))

1019

(labels ((walk-term (term)

1020

(unless (member term terms :test #'equalp)

1021

(push term terms)

1022

(loop for statement in field

1023

for (nil s nil o) = statement

1024

when (and (equalp o term)

1025

(not (member statement description)))

1026

do (progn (push statement description)

1027

(walk-term s))

1028

when (and (equalp s term)

1029

(not (member statement description)))

1030

do (progn (push statement description)

1031

(walk-term o))))))

1032

;; start rooted at the given subject

1033

(loop for statement in field

1034

for (nil s p o) = statement

1035

;; for all declared predicates

1036

when (and (member p slots :key #'slot-definition-store-property)

1037

(not (member statement description)))

1038

;; walk the path from the root

1039

do (cond ((equalp o subject)

1040

(push statement description)

1041

(walk-term s))

1042

((equalp s subject)

1043

(push statement description)

1044

(walk-term o)))))

1045

(values description))))

1046

1047

(defgeneric slot-definition-unbinder (sd)

1048

(:method ((sd t))

1049

'slot-makunbound))

1050

1051

(defgeneric merge-store-graph (resource addition-graph deletion-graph)

1052

(:method ((resource persistent-object) (addition-graph list) (deletion-graph list))

1053

;;(print :before)

1054

;; (describe resource)

1055

(ecase *decode-store-graph.mode*

1056

(:eval

1057

(let* ((identifier (instance-identifier resource))

1058

(slot-definitions (class-persistent-slots (class-of resource)))

1059

(new-graph (get-instance-store-graph resource)))

1060

          (setf deletion-graph (set-difference deletion-graph addition-graph :key #'third :test #'equalp))

1061

(loop for statement in deletion-graph ; store produces a quad field

1062

for (nil subject predicate object) = statement

1063

when (equalp subject identifier)

1064

do (let* ((sd (find predicate slot-definitions :key #'slot-definition-store-property))

1065

(unbinder (when sd (slot-definition-unbinder sd))))

1066

; do (print (list (list subject predicate object) sd writer))

1067

(when unbinder

1068

(setf new-graph (remove statement new-graph :test #'equalp))

1069

                       (funcall (fdefinition unbinder) resource) (sb-mop:slot-definition-name sd))))

1070

(loop for statement in addition-graph ; store produces a quad field

1071

for (nil subject predicate object) = statement

1072

when (equalp subject identifier)

1073

                do (let* ((sd (find predicate slot-definitions :key #'slot-definition-store-property))

1074

(writer (when sd (slot-definition-writer sd))))

1075

; do (print (list (list subject predicate object) sd writer))

1076

(when writer

1077

(pushnew statement new-graph :test #'equalp)

1078

                       (funcall (fdefinition writer) (compute-cspo-term-value object addition-graph) resource))))

1079

(setf-instance-store-graph new-graph resource))

1080

;(describe resource)

1081

resource)

1082

(:compile

1083

(let ((method-lambda (compute-merge-store-graph-lambda (class-of resource))))

1084

          (eval `(defmethod merge-store-graph ((resource ,(type-of resource)) (addition-graph list) (deletion-graph list))

1085

,@(cddr method-lambda)))

1086

(merge-store-graph resource addition-graph deletion-graph))))

1087

1088

#+(or)

1089

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

1090

(slot-definitions (class-persistent-slots class))

1091

(identifier (instance-identifier resource)))

1092

(loop for (nil subject predicate object) in graph

1093

for sd = (loop for sd in slot-definitions

1094

                            for slot-property = (some #'iri-p (c2mop:slot-definition-initargs sd))

1095

when (equalp slot-property predicate)

1096

return sd)

1097

for writer = (when sd (some #'store-writer-p (c2mop:slot-definition-writers sd)))

1098

when (and writer (equalp subject identifier))

1099

do (funcall writer object resource)))))

1100

1101

(defun merge-cspo-term-value (term statements)

1102

"Given a subject term and a statement field, compute the model value, which may be an instance

1103

or a list of values."

1104

(typecase term

1105

((or spocq:blank-node iri)

1106

(flet ((get-property (test-property)

1107

(loop for (nil subject property object) in statements

1108

when (and (equalp subject term) (equalp property test-property))

1109

return object)))

1110

(let* ((type (get-property |rdf|:|type|)))

1111

(cond ((and type (symbolp type))

1112

(merge-cspo-term-instance term

1113

(or (find-class type nil)

1114

                                                  (error "Invalid type in library resource graph: ~s" type))

1115

statements))

1116

((get-property |rdf|:|first|)

1117

(merge-cspo-term-list term statements))

1118

(t

1119

term)))))

1120

(t

1121

term)))

1122

1123

(defun merge-cspo-term-instance (term class statements)

1124

"Given a subject term, the respective class and a statement field, compute the model instance

1125

- correllate the field's statements with slot definitions

1126

- construct the value respective each slot definition

1127

- accumulate the values and initargs as an initialization list

1128

- create the instance with the constructed initargs "

1129

(let ((slot-definitions (class-persistent-slots class))

1130

(initargs ()))

1131

(loop for (nil subject property object) in statements

1132

for sd = (when (equalp subject term)

1133

(loop for sd in slot-definitions

1134

if (equalp property (slot-definition-decode-presentation-property sd))

1135

do (return sd)))

1136

if sd

1137

do (let ((value (merge-cspo-term-value object statements))

1138

(type (sb-mop:slot-definition-type sd)))

1139

            (when type (assert (typep value type) () "invalid property value: ~s: ~s." property value))

1140

(setf (getf initargs (first (c2mop:slot-definition-initargs sd))) value))

1141

else do (unless (member property '(|rdf|:|type| |rdf|:|first| |rdf|:|rest|

1142

                                                  |http://www.w3.org/2000/01/rdf-schema#|:|subClassOf|

1143

                                                  |http://www.w3.org/2000/01/rdf-schema#|:|comment|

1144

                                                  |http://www.w3.org/2000/01/rdf-schema#|:|label|))

1145

(log-warn "Unsupported property: ~s: ~s." class property)))

1146

(apply #'make-instance class initargs)))

1147

1148

(defun merge-cspo-term-list (term statements)

1149

   "given a graph as a list of statements and the term for the list head, compute the list of objects."

1150

(if (eq term |rdf|:|nil|)

1151

()

1152

(loop with first = nil

1153

with rest = nil

1154

for (nil subject predicate object) in statements

1155

when (equal term subject)

1156

do (case predicate

1157

(|rdf|:|first|

1158

(assert (null first) () "duplicate first in list graph: ~s" statements)

1159

(setf first (merge-cspo-term-value object statements)))

1160

(|rdf|:|rest|

1161

(assert (null rest) () "duplicate rest in list graph: ~s" statements)

1162

(setf rest (merge-cspo-term-value object statements)))

1163

(t

1164

(error "invalid predicate in list graph: ~s: ~s" predicate statements)))

1165

when (and first rest)

1166

return (cons first (merge-cspo-term-list rest statements))

1167

finally (error "head not in list graph: ~s: ~s" term statements))))

1168

1169

(defgeneric compute-merge-store-graph-lambda (class)

1170

(:method ((class symbol))

1171

(compute-merge-store-graph-lambda (find-class class)))

1172

(:method ((class persistent-class))

1173

(error "NYI")))

1174

1175

;;; higher level operators

1176

1177

(defgeneric unbind-resource (resource)

1178

(:documentation "Given a persistent resource, unbind all slots which reflect

1179

persistent state, The consequence is a dirty resource, not a hollow instance,

1180

as the semantics are to remove the state from the store.")

1181

1182

(:method ((resource persistent-object))

1183

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

1184

(slot-definitions (class-persistent-slots class)))

1185

(loop for sd in slot-definitions

1186

when (slot-definition-store-property sd)

1187

do (slot-makunbound resource (c2mop:slot-definition-name sd))

1188

finally (setf (instance-state resource) :hollow))

1189

resource)))

1190

1191

(defgeneric synchronize-resource (resource)

1192

(:documentation "Given a resource, ensure that it is clean and that its state reflects

1193

the revision which is current in its store. Return the possible re-read resource.

1194

It is split into two steps. first jusde if the instance is already synchrized partially

1195

by status and for active instances based on the revision.

1196

second, delegate to specilaized step to read the data from the store.")

1197

(:method :around ((resource persistent-object))

1198

(case (instance-state resource)

1199

((:deleted :detached) resource)

1200

(:new (call-next-method)) ; check if something has appeared

1201

(t (multiple-value-bind (s-p repository-revision)

1202

(resource-synchronized-p resource)

1203

(cond (s-p

1204

resource)

1205

(t

1206

(setf (instance-state resource) :hollow)

1207

(setf (instance-store-revision resource) repository-revision)

1208

(call-next-method)))))))

1209

(:method ((resource persistent-object))

1210

(case (instance-state resource)

1211

(:dirty

1212

(unbind-resource resource)

1213

(read-resource resource))

1214

((:new :hollow)

1215

(read-resource resource))

1216

(t

1217

        (warn "Anomalous resource state in synchronize-resource base method: ~s" (instance-state resource))

1218

resource))))

1219

1220

;;; methods require repository class

1221

+(or)

1222

(defgeneric align-resource-to-store (resource reference &key revision)

1223

(:documentation "On read, the revision is the resolved repository revision

1224

on write its is the revision to be created")

1225

)

1226

1227

1228

(defgeneric read-resource (resource &key revision)

1229

(:documentation "Read the state of the given resource from the store at a specified resource.

1230

If the resource state coincides, then decode the read field to

1231

bind the values to the respective slots. The respective graph comprises

1232

- all statements with the resource as subject

1233

- all first/rest statements in the resource's graph

1234

if a divergent revision is supplied, just read it, but do not decode.")

1235

1236

(:method ((resource persistent-object) &key (revision (instance-store-revision resource)))

1237

(let* ((repository (instance-repository resource))

1238

(identifier (instance-identifier resource))

1239

(graph (instance-graph-identifier resource)))

1240

(let ((field (append (repository-match-field repository graph identifier nil nil)

1241

                            (repository-match-field repository identifier nil |rdf|:|first| nil)

1242

                            (repository-match-field repository identifier nil |rdf|:|rest| nil))))

1243

(when (and field

1244

(or (resource-hollow-p resource) (resource-new-p resource))

1245

(equalp revision (instance-store-revision resource)))

1246

(decode-store-graph resource field))

1247

(values resource field))))

1248

1249

(:method ((resource persistent-graph-object) &key (revision (instance-store-revision resource)))

1250

(let* ((repository (instance-repository resource))

1251

(graph (instance-graph-identifier resource)))

1252

(let ((field (repository-match-field repository graph nil nil nil)))

1253

(when (equalp revision (instance-store-revision resource))

1254

(decode-store-graph resource field))

1255

(values resource field))))

1256

1257

(:method ((resource persistent-subject-object) &key (revision (instance-store-revision resource)))

1258

(let* ((repository (instance-repository resource))

1259

(identifier (instance-identifier resource)))

1260

(let ((field (repository-match-field repository |urn:dydra|:|all| identifier nil nil)))

1261

(when (and field

1262

(or (resource-hollow-p resource) (resource-new-p resource))

1263

(equalp revision (instance-store-revision resource)))

1264

(decode-store-graph resource field))

1265

(values resource field))))

1266

1267

(:method ((resource persistent-graph-subject-object) &key (revision (instance-store-revision resource)))

1268

(let* ((repository (instance-repository resource))

1269

(identifier (instance-identifier resource))

1270

(graph (instance-graph-identifier resource)))

1271

(let ((field (repository-match-field repository graph identifier nil nil)))

1272

(when (and field

1273

(or (resource-hollow-p resource) (resource-new-p resource))

1274

(equalp revision (instance-store-revision resource)))

1275

(decode-store-graph resource field))

1276

(values resource field))))

1277

1278

(:method ((resource described-object) &key (revision (instance-store-revision resource)))

1279

(let ((repository-id (instance-repository-id resource))

1280

(identifier (instance-identifier resource)))

1281

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

1282

         (let ((field (repository-match-cbd *transaction* identifier identifier (class-persistent-slots resource))))

1283

(when (and field

1284

(or (resource-hollow-p resource) (resource-new-p resource))

1285

(equalp revision (instance-store-revision resource)))

1286

(decode-store-graph resource field))

1287

(values resource field)))))

1288

1289

(:method :around ((resource persistent-object) &rest args)

1290

     ;; do not add a second synchronized-p test. leave that for the control flow through syncronize-resource

1291

(declare (ignore args) (dynamic-extent args))

1292

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

1293

(log-stacktrace "read-resource: ~a ~a : ~a"

1294

                                             (instance-repository-id resource)

1295

                                             (instance-identifier resource)

1296

c)

1297

;; if the read fails, leave the state unchanged

1298

(return-from read-resource nil))))

1299

(multiple-value-prog1 (call-next-method)

1300

(setf (instance-state resource) :clean)))))

1301

1302

;;; 2019-01-08 nxp-prod

1303

;;; (read-resource (repository "nxp/plm"))

1304

1305

(defparameter *commit-resource.verbose* nil)

1306

1307

(defgeneric commit-resource (resource)

1308

(:method :around ((resource standard-object))

1309

(case (instance-state resource)

1310

((:new :dirty)

1311

(let ((repository-id (instance-repository-id resource)))

1312

(cond ((and *transaction*

1313

(equal (repository-id *transaction*) repository-id))

1314

(call-next-method)

1315

                 (setf (instance-store-revision resource) (1+ (repository-last-revision repository-id))))

1316

(t

1317

(with-open-repository (repository-id :normal-disposition :commit)

1318

(call-next-method))

1319

(setf (instance-store-revision resource) (repository-last-revision repository-id))

1320

(setf (instance-state resource) :clean)))))

1321

(*commit-resource.verbose*

1322

(warn "skipped commit: [~s] ~s" (bt:thread-name sb-thread:*current-thread*) resource)))

1323

resource)

1324

1325

(:method ((resource persistent-object))

1326

(let* ((graph-to-insert (encode-store-graph resource)) ;; c-s-p-o

1327

(graph-to-delete (get-instance-store-graph resource)))

1328

(when graph-to-delete

1329

(repository-delete-field *transaction* graph-to-delete))

1330

(when graph-to-insert

1331

(multiple-value-bind (interned-graph node-map)

1332

                              (repository-intern-statements *transaction* graph-to-insert :skolemize t)

1333

;; insert the field and then cache the blank-node-mapped staement sequence

1334

;; for later use

1335

(repository-insert-field *transaction* interned-graph)

1336

(flet ((map-term (term)

1337

(or (rest (assoc term node-map)) term)))

1338

;; blank nodes cannot appear as predicates as those are slots

1339

(setf-instance-store-graph (loop for (nil s p o c) in graph-to-insert

1340

collect (list (map-term c) (map-term s) p (map-term o)))

1341

resource)))))))

1342

1343

1344

;;; utility operators

1345

1346

(defun compute-cspo-roots (graph)

1347

(let ((object-cache (make-hash-table :test #'equalp)))

1348

(loop for statement in graph

1349

for object = (fourth statement)

1350

do (setf (gethash object object-cache) t))

1351

(loop with roots = ()

1352

for statement in graph

1353

for subject = (second statement)

1354

unless (gethash subject object-cache)

1355

do (pushnew subject roots :test #'equalp)

1356

finally (return roots))))

1357

;;; (compute-cspo-roots '((c root 1 o1) (c root 2 o2) (c o1 3 o4)))

1358

1359

(defun compute-spo-roots (graph)

1360

(let ((object-cache (make-hash-table :test #'equalp)))

1361

(loop for statement in graph

1362

for object = (third statement)

1363

do (setf (gethash object object-cache) t))

1364

(loop with roots = ()

1365

for statement in graph

1366

for subject = (first statement)

1367

unless (gethash subject object-cache)

1368

do (pushnew subject roots :test #'equalp)

1369

finally (return roots))))

1370

1371

#|

1372

1373

(defgeneric boxed-+ (arg1 arg2)

1374

(:method ((arg1 number) (arg2 number))

1375

(+ arg1 arg2))

1376

(:method ((arg1 spocq:integer) (arg2 spocq:integer))

1377

(let ((value (+ (literal-value arg1) (literal-value arg2))))

1378

(make-integer-literal :cached-value value :string (prin1-to-string value)))))

1379

1380

(defun do-generic (arg1 arg2 &key (count 1000000))

1381

(let ((v nil))

1382

(dotimes (i count v) (setf v (boxed-+ arg1 arg2)))

1383

v))

1384

1385

(defun do-native (arg1 arg2 &key (count 1000000))

1386

(let ((v nil))

1387

(dotimes (i count v) (setf v (+ arg1 arg2)))

1388

v))

1389

1390

;; (time (do-generic 100 100))

1391

;; (time (do-native 100 100))

1392

;; (time (do-generic (spocq:make-integer :lexical-form "100") (spocq:make-integer :lexical-form "100")))

1393

1394

1395

|#

1396

��