Coverage report: /development/source/library/org/datagraph/spocq-shard/src/algebra/operators/dydra-operators.lisp

Kind	Covered	All	%
expression	34	1130	3.0
branch	0	66	0.0

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 the GIS extension operators for the 'org.datagraph.spocq' RDF engine."

6

7

(copyright

8

9

10

(long-description

11

"The file defines the dydra extension operators for SPOCQ. The initial complement emulates the

12

Virtuose SPARQL extensions[1] to support the good relations PHP API[2].

13

14

---

15

[1]: http://docs.openlinksw.com:80/virtuoso/functions.html

16

[2]: http://code.google.com/p/gr4php/source/browse/gr4php_template.php

17

"))

18

19

20

(defstruct point x y)

21

22

(defun |dydra|:|contains| (string substring)

23

(when (search substring string)))

24

25

(defun |dydra|:|round| (term)

26

(spocq.e::round term))

27

28

(defun |dydra|:|st_distance| (point-1 point-2)

29

(flet ((square (x) (* x x)))

30

(sqrt (+ (square (- (point-x point-1) (point-x point-2)))

31

(square (- (point-y point-1) (point-y point-2)))))))

32

33

(defun |dydra|:|st_point| (latitude longitude)

34

(make-point :x latitude :y longitude))

35

36

(defun |dydra|:|st_x| (point)

37

(point-x point))

38

39

(defun |dydra|:|st_y| (point)

40

(point-y point))

41

42

43

44

(defgeneric |dydra|:|format| (value specification &key zone)

45

(:method ((value spocq:date-time) (specification string) &key (zone 0))

46

(with-output-to-string (stream)

47

(multiple-value-call #'format-time-values

48

stream specification

49

(decode-temporal value zone))))

50

(:method ((value spocq:date) (specification string) &key (zone 0))

51

(with-output-to-string (stream)

52

(multiple-value-call #'format-time-values

53

stream specification

54

(decode-temporal value zone))))

55

(:method ((value integer) (specification string) &key (zone 0))

56

(with-output-to-string (stream)

57

(multiple-value-call #'format-time-values

58

stream specification

59

(decode-temporal value zone))))

60

(:method ((value spocq:duration) (specification string) &key (zone 0))

61

(with-output-to-string (stream)

62

(multiple-value-call #'format-time-values

63

stream specification

64

(decode-temporal value zone))))

65

(:method ((value spocq:time) (specification string) &key (zone 0))

66

(with-output-to-string (stream)

67

(multiple-value-call #'format-time-values

68

stream specification

69

(decode-temporal value zone)))))

70

;;; (|dydra|:|format| (spocq.e:now) "%Y-%m-%dT%H:%i:%s")

71

;;; (|dydra|:|format| (spocq.e:now) "%Y-%m-%dT%H:%i:%s" 3)

72

73

74

(defun format-time-values (stream specification fraction second minute hour day month year)

75

(let ((index 0)

76

(length (length specification))

77

(day-of-the-week nil))

78

(flet ((local-day-of-the-week ()

79

(or day-of-the-week

80

(setf day-of-the-week

81

(multiple-value-bind (second minute hour day month year dotw)

82

                                             (decode-universal-time (encode-universal-time second minute hour day month year 0))

83

(declare (ignore second minute hour day month year))

84

dotw)))))

85

(loop (when (>= index length) (return))

86

(let ((char (char specification index)))

87

(case char

88

(#\%

89

(when (< (incf index) length)

90

(case (char specification index)

91

(#\a ;Abbreviated weekday name

92

                       (write-string (subseq (date:day-in-week-name (local-day-of-the-week)) 0 3) stream))

93

(#\b ;Abbreviated month name

94

(write-string (subseq (date:month-name month) 0 3) stream))

95

(#\c ;Month, numeric

96

(princ month stream))

97

(#\D ;Day of month with English suffix

98

(format stream "~:r" month))

99

(#\d ;Day of month, numeric (00-31)

100

(format stream "~2,'0d" day))

101

(#\e ;Day of month, numeric (0-31)

102

(princ day stream))

103

(#\f ;Microseconds

104

(princ (if fraction (round fraction .000001) 0) stream))

105

(#\H ;Hour (00-23)

106

(format stream "~2,'0d" hour))

107

(#\h ;Hour (01-12)

108

(let ((mod-12 (mod hour 12)))

109

(format stream "~2,'0d" (if (zerop mod-12) 12 mod-12))))

110

(#\I ;Hour (01-12)

111

(let ((mod-12 (mod hour 12)))

112

(format stream "~2,'0d" (if (zerop mod-12) 12 mod-12))))

113

(#\i ;Minutes, numeric (00-59)

114

(format stream "~2,'0d" minute))

115

(#\j ;Day of year (001-366)

116

                       (let ((doy (date:day-and-month-to-day-in-year day month (date:leap-p year))))

117

(format stream "~3,'0d" doy)))

118

(#\k ;Hour (0-23)

119

(format stream "~2,'0d" hour))

120

(#\l ;Hour (1-12)

121

(let ((mod-12 (mod hour 12)))

122

(princ (if (zerop mod-12) 12 mod-12) stream)))

123

(#\M ;Month name

124

(write-string (date:month-name month) stream))

125

(#\m ;Month, numeric (00-12)

126

(format stream "~2,'0d" month)

127

)

128

(#\p ;AM or PM

129

(write-string (if (>= hour 12) "PM" "AM") stream))

130

(#\r ;Time, 12-hour (hh:mm:ss AM or PM)

131

(let ((mod-12 (mod hour 12)))

132

                         (format stream "~2,'0d:~2,'0d:~2,'0d" (if (zerop mod-12) 12 mod-12) minute second)))

133

(#\S ;Seconds (00-59)

134

(format stream "~2,'0d" second))

135

(#\s ;Seconds (00-59)

136

(format stream "~2,'0d" second))

137

(#\T ;Time, 24-hour (hh:mm:ss)

138

(format stream "~2,'0d:~2,'0d:~2,'0d" hour minute second))

139

                      (#\U       ;Week (00-53) where Sunday is the first day of week

140

                       (format stream "~2,'0d" (date::day-and-month-any-year-to-week-in-year day month year :start-of-week :sunday)))

141

                      (#\u       ;Week (00-53) where Monday is the first day of week

142

                       (format stream "~2,'0d" (date::day-and-month-any-year-to-week-in-year day month year)))

143

                      (#\V       ;Week (01-53) where Sunday is the first day of week, used with %X

144

                       (format stream "~2,'0d" (1+ (date::day-and-month-any-year-to-week-in-year day month year :start-of-week :sunday))))

145

                      (#\v       ;Week (01-53) where Monday is the first day of week, used with %x

146

                       (format stream "~2,'0d" (1+ (date::day-and-month-any-year-to-week-in-year day month year))))

147

(#\W ;Weekday name

148

                       (write-string (date:day-in-week-name (mod (1+ (local-day-of-the-week)) 7)) stream))

149

(#\w ;Day of the week (0=Sunday, 6=Saturday)

150

(princ (mod (1+ (local-day-of-the-week)) 7) stream))

151

                      (#\X       ;Year of the week where Sunday is the first day of week, four digits, used with %V

152

(format stream "~4,'0d" year)) ; ??

153

                      (#\x       ;Year of the week where Monday is the first day of week, four digits, used with %v

154

(format stream "~4,'0d" year)) ; ??

155

(#\Y ;Year, four digits

156

(format stream "~4,'0d" year))

157

(#\y ;Year, two digits

158

(format stream "~2,'0d" (mod year 100)))))

159

(incf index))

160

(t

161

(write-char char stream)

162

(incf index))))))))

163

164

(defun date::day-and-month-any-year-to-week-in-year (day month year &key (start-of-week :monday))

165

(multiple-value-bind (s m h d mo y ysdow)

166

                        (decode-universal-time (encode-universal-time 1 1 1 1 1 year 0) 0)

167

(declare (ignore s m h d mo y))

168

(let* ((doy (date:day-and-month-to-day-in-year day month (date:leap-p year)))

169

(week (floor (+ doy ysdow (ecase start-of-week (:monday -1) (:sunday 0))) 7)))

170

(values week ysdow doy))))

171

172

173

;;; (format-time-values t "%Y-%m-%dT%H" nil 1 1 1 1 5 2006 0 nil 0)

174

;;; (get-decoded-time)

175

 ;;; (loop for day from 1 to 15 collect (list day (date::day-and-month-any-year-to-week-in-year day 1 2013)))

176

 ;;; (loop for day from 1 to 15 collect (list day (date::day-and-month-any-year-to-week-in-year day 1 2013 :start-of-week :sunday)))

177

;;; (|dydra|:|format| (spocq.e:now) "%Y-%m-%d")

178

;;;

179

180

(defgeneric |dydra|:|timestamp-date-time| (timestamp)

181

(:method ((timestamp integer))

182

(if (plusp timestamp)

183

(timeline-location-date-time timestamp)

184

(call-next-method)))

185

(:method ((timestamp t))

186

(invalid-argument-type |dydra|:|timestamp-date-time| timestamp |xsd|:|nonNegativeInteger|)))

187

188

(defgeneric |dydra|:|date-time-timestamp| (timestamp)

189

(:method ((date-time spocq:date-time))

190

(date-time-timeline-location date-time))

191

(:method ((date-time t))

192

(invalid-argument-type |dydra|:|date-time-timestamp| date-time |xsd|:|dateTime|)))

193

194

;;; iri operators

195

196

(defun |dydra|:|iri-authority| (iri)

197

(puri:uri-authority (puri:uri iri)))

198

199

(defun |dydra|:|iri-fragment| (iri)

200

(puri:uri-fragment (puri:uri iri)))

201

202

(defun |dydra|:|iri-host| (iri)

203

(puri:uri-host (puri:uri iri)))

204

205

(defun |dydra|:|iri-path| (iri)

206

(puri:uri-path (puri:uri iri)))

207

208

(defun |dydra|:|iri-password| (iri)

209

(puri:uri-password (puri:uri iri)))

210

211

(defun |dydra|:|iri-port| (iri)

212

(puri:uri-port (puri:uri iri)))

213

214

(defun |dydra|:|iri-query| (iri)

215

(puri:uri-query (puri:uri iri)))

216

217

(defun |dydra|:|iri-scheme| (iri)

218

(let ((scheme (puri:uri-scheme (puri:uri iri))))

219

(if scheme (string scheme) "")))

220

221

(defun |dydra|:|iri-user| (iri)

222

(puri:uri-user (puri:uri iri)))

223

224

(defun |dydra|:|iri-userinfo| (iri)

225

(puri:uri-userinfo (puri:uri iri)))

226

227

#+(or)

228

(let ((iri (spocq.e:iri "http://user:pw@host.net:0001/path1/path2/object.ext?parm1=1&parm2=2#fragment")))

229

(loop for function being each external-symbol in "http://dydra.com#"

230

for name = (string function)

231

when (and (> (length name) 4) (string-equal "iri-" name :end2 4))

232

collect (list function (funcall function iri))))

233

234

(defmethod |dydra|:|urn-uuid-string| ((uuid spocq:uuid))

235

(subseq (spocq::uuid-lexical-form uuid) 9))

236

237

;;; (|dydra|:|urn-uuid-string| (intern-iri (make-v1-uuid-string)))

238

239

#|

240

* (run-test-query "select (<http://dydra.com#format>(?date, '%Y-%m-%d') as ?ts)

241

(str(?date) as ?str)

242

where { ?s <http://example.org/date> ?date }"

243

:repository-id (lookup-repository-id :repository-name "functions-day-zulu" :account-name "jhacker"))

244

245

(("2010-06-21" "2010-06-21T11:28:01Z") ("2010-12-21" "2010-12-21T23:38:02Z")

246

("2008-06-20" "2008-06-20T23:59:00Z") ("2011-02-01" "2011-02-01T01:02:03Z")

247

("2011-01-01" "2011-01-01T03:02:03Z") ("2011-01-01" "2011-01-01T01:02:03Z")

248

("2010-12-31" "2010-12-31T23:02:03Z") ("2012-01-01" "2012-01-01T01:24:25Z")

249

("2011-12-31" "2011-12-31T23:24:25Z") ("2011-12-31" "2011-12-31T21:24:25Z"))

250

(?::|ts| ?::|str|)

251

252

253

(run-test-query "

254

select ?ts (count(?date) as ?count) {

255

select (<http://dydra.com#format>(?date, '%Y-%m-%d', +4) as ?ts) ?date

256

where { ?s <http://example.org/date> ?date }

257

}

258

group by ?ts"

259

:repository-id (lookup-repository-id :repository-name "functions-day-zulu" :account-name "jhacker"))

260

(("2010-06-21" 1) ("2010-12-21" 1) ("2008-06-20" 1) ("2011-01-31" 1)

261

("2010-12-31" 3) ("2011-12-31" 3))

262

(?::|ts| ?::|count|)

263

|#

264

265

266

(:documentation "Reification"

267

                 "The identifier for a statement is a tri-part urn, of which each component is the respective

268

  term sha-1. It has meaning for only those combinations for which the terms exist in the store and is

269

  intended itself to be interned. That is, if the identifer has not been interned, the return values from

270

the component accessors will all be unbound indicators."

271

)

272

273

(defun |dydra|::|statement-urn| (subject predicate object)

274

(unless (or (spocq:iri-p subject) (spocq:blank-node-p subject))

275

(spocq.e:argument-type-error :datum subject

276

:operator '|dydra|::|statement-urn|

277

:expected-type '(or spocq:iri spocq:blank-node)))

278

(unless (spocq:iri-p predicate)

279

(spocq.e:argument-type-error :datum predicate

280

:operator '|dydra|::|statement-urn|

281

:expected-type 'spocq:iri))

282

(let ((subject-id (rlmdb:value-term-number subject :if-does-not-exist nil))

283

(predicate-id (rlmdb:value-term-number predicate :if-does-not-exist nil))

284

(object-id (rlmdb:value-term-number object :if-does-not-exist nil)))

285

(if (and subject-id predicate-id object-id)

286

(intern-iri (rdf-statement-urn-string subject-id predicate-id object-id))

287

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-subject|)))))

288

289

(defun rdf-statement-urn-string (subject-id predicate-id object-id)

290

"Given three term numbers, compute the respective id urn string.

291

This permits constructs for statements which do not exist in the store, so long as the terms do"

292

(dydra-ndk::statement-urn-string subject-id predicate-id object-id))

293

294

295

(defun |dydra|:|statement-subject| (id-urn)

296

"Given an urn identifier for a known statement, return the component."

297

(typecase id-urn

298

(spocq:iri

299

(let ((statement-id-term-number (rlmdb:value-term-number id-urn :if-does-not-exist nil)))

300

(if statement-id-term-number

301

;; the terms must have been interned

302

(rlmdb:term-number-value (dydra-ndk::statement-subject-id statement-id-term-number))

303

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-subject|)))))

304

(spocq:unbound-variable

305

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-subject|)))

306

(t

307

(spocq.e:argument-type-error :datum id-urn

308

:operator '|dydra|:|statement-subject|

309

:expected-type 'spocq:iri))))

310

311

(define-compiler-macro |dydra|:|statement-subject| (&whole form id-urn &environment env)

312

(let ((expansion (macroexpand-1 id-urn env)))

313

(if (field-object-aref-p expansion)

314

`(let ((.term-number (aref ,@(field-object-aref-aref expansion))))

315

(if (eql .term-number +null-term+)

316

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-subject|))

317

(rlmdb:term-number-value (dydra-ndk::statement-subject-id .term-number))))

318

form)))

319

320

321

(defun |dydra|:|statement-predicate| (id-urn)

322

"Given an urn identifier for a known statement, return the component."

323

(typecase id-urn

324

(spocq:iri

325

(let ((statement-id-term-number (rlmdb:value-term-number id-urn :if-does-not-exist nil)))

326

(if statement-id-term-number

327

;; the terms must have been interned

328

(rlmdb:term-number-value (dydra-ndk::statement-predicate-id statement-id-term-number))

329

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-predicate|)))))

330

(spocq:unbound-variable

331

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-predicate|)))

332

(t

333

(spocq.e:argument-type-error :datum id-urn

334

:operator '|dydra|:|statement-predicate|

335

:expected-type 'spocq:iri))))

336

337

(define-compiler-macro |dydra|:|statement-predicate| (&whole form id-urn &environment env)

338

(let ((expansion (macroexpand-1 id-urn env)))

339

(if (field-object-aref-p expansion)

340

`(let ((.term-number (aref ,@(field-object-aref-aref expansion))))

341

(if (eql .term-number +null-term+)

342

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-predicate|))

343

(rlmdb:term-number-value (dydra-ndk::statement-predicate-id .term-number))))

344

form)))

345

346

347

(defun |dydra|:|statement-object| (id-urn)

348

"Given an urn identifier for a known statement, return the component."

349

(typecase id-urn

350

(spocq:iri

351

(let ((statement-id-term-number (rlmdb:value-term-number id-urn :if-does-not-exist nil)))

352

(if statement-id-term-number

353

;; the terms must have been interned

354

(rlmdb:term-number-value (dydra-ndk::statement-object-id statement-id-term-number))

355

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-object|)))))

356

(spocq:unbound-variable

357

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-object|)))

358

(t

359

(spocq.e:argument-type-error :datum id-urn

360

:operator '|dydra|:|statement-object|

361

:expected-type 'spocq:iri))))

362

(define-compiler-macro |dydra|:|statement-object| (&whole form id-urn &environment env)

363

(let ((expansion (macroexpand-1 id-urn env)))

364

(if (field-object-aref-p expansion)

365

`(let ((.term-number (aref ,@(field-object-aref-aref expansion))))

366

(if (eql .term-number +null-term+)

367

(load-time-value (spocq:make-unbound-variable '|dydra|:|statement-object|))

368

(rlmdb:term-number-value (dydra-ndk::statement-object-id .term-number))))

369

form)))

370

371

372

;;; query state introspection

373

374

(defun |dydra|:|account-name| ()

375

(or (when *task*

376

(let ((account (or (task-account *task*)

377

(repository-account (task-repository *task*)))))

378

(when account (account-name account))))

379

(load-time-value (spocq:make-unbound-variable '|dydra|:|account-name|))))

380

381

(defun |dydra|:|agent-id| ()

382

"Return the agent id respective the current task or, if none is available, an

383

unbound value."

384

(or (task-agent-id *task*)

385

(load-time-value (spocq:make-unbound-variable '|dydra|:|agent-id|))))

386

387

(defun |dydra|:|agent-location| ()

388

"Return the agent location respective the current task or, if none is available, an

389

unbound value."

390

(or (task-agent-location *task*)

391

(load-time-value (spocq:make-unbound-variable '|dydra|:|agent-location|))))

392

393

(defun |dydra|:|client-request-id| () (|dydra|:|user-tag|))

394

395

396

;;; !!! nb. there is no |dydra|:|event| operator

397

;;; an event binding is a side-effect of statement scanning for indices which include

398

;;; an event designator in the key

399

400

(defgeneric |dydra|:|event-ordinal| (event-designator)

401

(:documentation "Return the equivalent event ordinal for the current repository.

402

Given an ordinal, return it directly.")

403

(:method ((designator integer))

404

designator)

405

(:method ((designator t))

406

(or (when *repository*

407

(let ((record (rlmdb:find-revision-record *repository* designator)))

408

(when record

409

(rlmdb:revision-record-ordinal record))))

410

(load-time-value (spocq:make-unbound-variable '|dydra|:|event-ordinal|)))))

411

412

(defgeneric |dydra|:|event-timestamp| (event-designator)

413

(:documentation "Return the equivalent date-time timestamp for the current repository.

414

Given a timestamp. return it directly")

415

(:method ((designator spocq:date-time))

416

designator)

417

(:method ((designator t))

418

(or (when *repository*

419

(let ((record (rlmdb:find-revision-record *repository* designator)))

420

(when record

421

(timeline-location-date-time (rlmdb:revision-record-timestamp record)))))

422

(load-time-value (spocq:make-unbound-variable '|dydra|:|event-timestamp|)))))

423

424

(defgeneric |dydra|:|event-uuid| (event-designator)

425

(:documentation "Return the equivalent uuid string for the current repository.

426

Given an uuid. return it directly")

427

(:method ((designator string))

428

(or (when *repository*

429

(let ((record (rlmdb:find-revision-record *repository* designator)))

430

(when record

431

(rlmdb:revision-record-uuid record))))

432

(load-time-value (spocq:make-unbound-variable '|dydra|:|event-uuid|)))))

433

434

435

(defun |dydra|:|query-uri| ()

436

"This function returns the IRI of the current query."

437

(or (when *task* (task-uuid *task*))

438

(load-time-value (spocq:make-unbound-variable '|dydra|:|query-uri|))))

439

440

(defun |dydra|:|repository-name| ()

441

"Return the name of the current query's target repository"

442

(or (when *task* (repository-name (task-repository *task*)))

443

(load-time-value (spocq:make-unbound-variable '|dydra|:|repository-name|))))

444

445

;;; the now returns the incorrect uri - therepository rahter than with the revision

446

(defun |dydra|:|repository-revision-url| ()

447

"Return the URL of the current query's repository's revision"

448

(or (when *task* (repository-revision-uri (task-transaction *task*)))

449

(load-time-value (spocq:make-unbound-variable '|dydra|:|repository-revision-url|))))

450

451

(defun |dydra|:|repository-revision-count| ()

452

"Return the number of revisions for a revisioned repository.

453

If unrevisioned, return 0 - even though there is always one revision."

454

(or (when *task*

455

(let ((repository (task-repository *task*)))

456

(if (repository-is-revisioned repository)

457

(length (repository-list-revision-ids repository))

458

0)))

459

(load-time-value (spocq:make-unbound-variable '|dydra|:|repository-revision-url|))))

460

461

(defun |dydra|:|repository-url| ()

462

"Returns the URL of the current query's repository"

463

(or (when *task* (repository-uri (task-repository *task*)))

464

(load-time-value (spocq:make-unbound-variable '|dydra|:|repository-url|))))

465

466

(defun |dydra|:|request-id| () (|dydra|:|query-uri|))

467

468

(defun |dydra|:|resolve-revision| (revision-designator &optional silent)

469

"Given a revision designator, resolve it to the respective uuid and return the value"

470

(unless (stringp revision-designator)

471

(spocq.e:argument-type-error :datum revision-designator

472

:operator '|dydra|:|resolve-revision|

473

:expected-type |xsd|:|string|))

474

(or (when *repository* (let* ((if-does-not-exist (if (ebv silent) nil :error))

475

(id (resolve-repository-revision-id *repository*

476

                                                               :revision revision-designator

477

                                                               :if-does-not-exist if-does-not-exist)))

478

(when id (intern-uuid id))))

479

(load-time-value (spocq:make-unbound-variable '|dydra|:|resolve-revision|))))

480

481

;;; revision-based operators are of two kinds

482

;;; the first regard properties of the active revision and/or task's transaction

483

;;; (which ought to be the same?)

484

;;; the second relate as well to revision identifiers

485

(defun |dydra|:|revision-parent-uri| ()

486

"This function returns the IRI of the current query's active transactions's parent."

487

(or (when *task* (revision-parent-uri (task-transaction *task*)))

488

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision-parent-uri|))))

489

490

(defgeneric |dydra|:|revision-predecessor| (revision-designator)

491

(:documentation "Return the revision which precedes that given.")

492

(:method ((revision rlmdb:revision-record))

493

(when *repository*

494

(let ((record (rlmdb:find-revision-record *repository* revision :offset -1

495

                                                 :if-does-not-exist nil)))

496

(or record

497

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision-predecessor|))))))

498

(:method ((designator t))

499

(let ((record (|dydra|:|revision| designator)))

500

(typecase record

501

(rlmdb:revision-record (|dydra|:|revision-predecessor| record))

502

(t (load-time-value (spocq:make-unbound-variable '|dydra|:|revision-predecessor|)))))))

503

504

(defgeneric |dydra|:|revision-successor| (revision-designator)

505

(:documentation "Return the revision which precedes that given.")

506

(:method ((revision rlmdb:revision-record))

507

(when *repository*

508

(let ((record (rlmdb:find-revision-record *repository* revision :offset -1

509

                                                 :if-does-not-exist nil)))

510

(or record

511

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision-successor|))))))

512

(:method ((designator t))

513

(let ((record (|dydra|:|revision| designator)))

514

(typecase record

515

(rlmdb:revision-record (|dydra|:|revision-successor| record))

516

(t (load-time-value (spocq:make-unbound-variable '|dydra|:|revision-successor|)))))))

517

518

;;; |dydra|:|revision-end-uri| : see rmdb/repositorystreaming

519

;;; |dydra|:|revision-start-uri| : see rmdb/repositorystreaming

520

521

(defgeneric |dydra|:|revision| (revision-designator)

522

(:documentation "Return the rlmdb revision record respective the given designator.")

523

(:method ((revision rlmdb:revision-record))

524

revision)

525

(:method ((revision integer))

526

(if *repository*

527

(let ((record (rlmdb:find-revision-record *repository* revision)))

528

(if record

529

record

530

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

531

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision|))))

532

(:method ((revision vector))

533

(if *repository*

534

(let ((record (rlmdb:find-revision-record *repository* revision)))

535

(if record

536

record

537

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

538

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision|))))

539

(:method ((revision repository-revision))

540

(repository-revision-record revision))

541

(:method ((revision null))

542

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision|)))

543

(:method ((revision spocq:unbound-variable))

544

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision|)))

545

(:method ((revision t))

546

547

548

549

(defgeneric |dydra|:|revision-date-time| (revision)

550

(:documentation "Return the dateTime for the respective revision's commit timestamp")

551

(:method ((revision rlmdb:revision-record))

552

(rlmdb:revision-record-date-time revision))

553

(:method ((designator t))

554

(let ((record (|dydra|:|revision| designator)))

555

(typecase record

556

(rlmdb:revision-record (rlmdb:revision-record-date-time record))

557

(t (load-time-value (spocq:make-unbound-variable '|dydra|:|revision-date-time|)))))))

558

559

560

(defgeneric |dydra|:|revision-ordinal| (revision)

561

(:documentation "Return the revision's internal revision ordinal")

562

(:method ((revision rlmdb:revision-record))

563

(rlmdb:revision-record-ordinal revision))

564

(:method ((designator t))

565

(let ((record (|dydra|:|revision| designator)))

566

(typecase record

567

(rlmdb:revision-record (rlmdb:revision-record-ordinal record))

568

(t (load-time-value (spocq:make-unbound-variable '|dydra|:|revision-ordinal|)))))))

569

570

571

(defgeneric |dydra|:|revision-commit-timestamp| (revision)

572

(:documentation "Return the respective revision's commit unix timestamp")

573

(:method ((revision rlmdb:revision-record))

574

(rlmdb:revision-record-timestamp revision))

575

(:method ((designator t))

576

(let ((record (|dydra|:|revision| designator)))

577

(typecase record

578

(rlmdb:revision-record (rlmdb:revision-record-timestamp record))

579

(t (load-time-value (spocq:make-unbound-variable '|dydra|:|revision-commit-timestamp|)))))))

580

581

582

(defgeneric |dydra|:|revision-begin-timestamp| (revision)

583

(:documentation "Return the respective revision's start unix timestamp")

584

(:method ((revision rlmdb:revision-record))

585

(rlmdb:revision-record-timestamp-begun revision))

586

(:method ((designator t))

587

(let ((record (|dydra|:|revision| designator)))

588

(typecase record

589

(rlmdb:revision-record (rlmdb:revision-record-timestamp-begun record))

590

(t (load-time-value (spocq:make-unbound-variable '|dydra|:|revision-begin-timestamp|)))))))

591

592

593

(defgeneric |dydra|:|revision-uuid| (revision)

594

(:documentation "Return the respective revision's uuid")

595

(:method ((revision rlmdb:revision-record))

596

(rlmdb:revision-record-uuid revision))

597

(:method ((designator t))

598

(let ((record (|dydra|:|revision| designator)))

599

(typecase record

600

(rlmdb:revision-record (rlmdb:revision-record-uuid record))

601

(t (load-time-value (spocq:make-unbound-variable '|dydra|:|revision-uuid|)))))))

602

603

604

;;; concerning the identifier

605

(defgeneric |dydra|:|revision-uuid-node| (uri)

606

(:documentation "Return the node field of the revision uuid")

607

(:method ((uri null))

608

nil)

609

(:method ((uri string))

610

(uuid-node uri))

611

(:method ((uri spocq:uuid))

612

(uuid-node uri))

613

(:method ((uri vector))

614

(uuid-node uri))

615

(:method ((revision t))

616

(|dydra|:|revision-uuid-node| (|dydra|:|revision-uuid| revision))))

617

618

(defgeneric |dydra|:|revision-uuid-timestamp| (uri)

619

(:documentation "Return the timestamp field of the revision uuid")

620

(:method ((uri null))

621

nil)

622

(:method ((uri string))

623

(v1-uuid-timestamp uri))

624

(:method ((uri spocq:uuid))

625

(v1-uuid-timestamp uri))

626

(:method ((uri vector))

627

(v1-uuid-timestamp uri))

628

(:method ((revision t))

629

(|dydra|:|revision-uuid-timestamp| (|dydra|:|revision-uuid| revision))))

630

631

632

;;; the version operators concern the attributes of the current revision or

633

;;; - when in the context of a bgp, the matched statement's revision.

634

;;; this is handled by the continuation in the bgp which accepts matched quads

635

;;; and their respective visibility bounds

636

637

(defun |dydra|:|version| (&optional (version *version*))

638

"This function returns the revision interval version instance comprising the

639

current start revision and optionally the end revision.

640

If no dynamic binding exists, it constructs a new instance."

641

(cond (version)

642

(*repository*

643

(spocq:make-revision-interval

644

:start (repository-revision-record *repository*)

645

:end (rlmdb:find-revision-record *repository*

646

                                            (1+ (repository-revision-ordinal *repository*)))))

647

(t

648

(load-time-value (spocq:make-unbound-variable '|dydra|:|version|)))))

649

650

651

"This function returns the IRI of the end revision of a visibility constraint"

652

(or (revision-interval-end-date-time version) |rdf|:|nil|))

653

654

655

"This function returns the IRI of the end revision of a visibility constraint"

656

(or (revision-interval-end-ordinal version) |rdf|:|nil|))

657

658

659

"This function returns the IRI of the end revision of a visibility constraint"

660

(or (revision-interval-end-uuid version) |rdf|:|nil|))

661

662

663

664

"This function returns the IRI of the start revision of a visibility constraint"

665

(revision-interval-start-date-time version))

666

667

668

"This function returns the IRI of the start revision of a visibility constraint"

669

(revision-interval-start-ordinal version))

670

671

672

"This function returns the IRI of the start revision of a visibility constraint"

673

(revision-interval-start-uuid version))

674

675

676

677

(defun |dydra|:|revision-signature| ()

678

"This function returns a digest signature of the query's active revision.

679

If none is available, it returns rdf:nil"

680

(or (when *task*

681

(let ((signature (revision-signature (task-transaction *task*))))

682

(typecase signature

683

             (vector (intern-iri (format nil "urn:hash::sha256:~a" (binascii:encode signature :base32))))

684

(t nil))))

685

|rdf|:|nil|))

686

687

(defun |dydra|:|revision-uri| (&optional revision)

688

"This function returns the IRI of the current query's active revision"

689

(typecase revision

690

(null (or (when *task* (revision-uri (task-transaction *task*)))

691

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision-uri|))))

692

(integer (let ((record (rlmdb:get-revision-uuid *repository* revision)))

693

(if record

694

(rlmdb:revision-record-uuid record)

695

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision-uri|)))))

696

(t

697

(load-time-value (spocq:make-unbound-variable '|dydra|:|revision-uri|)))))

698

699

(defun |dydra|:|transaction-uri| ()

700

"This function returns the IRI of the current query's active transaction."

701

(or (when *task* (transaction-uri (task-transaction *task*)))

702

(load-time-value (spocq:make-unbound-variable '|dydra|:|transaction-uri|))))

703

704

(defun |dydra|:|user-tag| ()

705

(or (when *task*

706

(task-user-tag *task*))

707

(load-time-value (spocq:make-unbound-variable '|dydra|:|user-tag|))))

708

709

;;; if the situation allows, return the term number driectly, otherwise concert.

710

 ;;; the fomer matters in those cases where the attempt to convert the term to the interned value would signal an error.

711

712

(defun |dydra|::|term-number| (object)

713

(repository-object-term-number *transaction* object))

714

715

(define-compiler-macro |dydra|::|term-number| (expression &environment env)

716

"if possible, return the value in-line, other wise delegate to the object-based execution."

717

(let ((expression-expansion (macroexpand-1 expression env)))

718

(if (field-object-aref-p expression-expansion)

719

`(aref ,@(field-object-aref-aref expression-expansion))

720

expression)))

721

722

;;; list operations

723

724

(defpackage "http://dydra.com/list-processing#"

725

(:nicknames "lisp")

726

(:use )

727

(:export "first"

728

"last"

729

"nth"

730

"nthcdr"

731

"member"

732

"rest"))

733

734

(cl-user::add-iri-package "http://dydra.com/list-processing#")

735

736

737

(defun rdf-match-object (&key (wild (repository-wildcard-term *transaction*))

738

(g wild)

739

(s wild)

740

(p wild))

741

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

742

(declare (ignore c s p))

743

(return-from rdf-match-object o)))

744

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

745

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

746

;; if it returns, then nothing matched

747

+null-term+))

748

749

(defun rdf-match-subject (&key (wild (repository-wildcard-term *transaction*))

750

(g wild)

751

(p wild)

752

(o wild))

753

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

754

(declare (ignore c p o))

755

(return-from rdf-match-subject s)))

756

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

757

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

758

;; if it returns, then nothing matched

759

+null-term+))

760

761

762

(defun rdf-first (cons-term)

763

(if (or (eql cons-term +null-term+)

764

(eql cons-term (symbol-term-id |rdf|:|nil|)))

765

cons-term

766

(rdf-match-object :s cons-term :p (symbol-term-id |rdf|:|first|))))

767

768

(defun rdf-rest (cons-term)

769

(if (or (eql cons-term +null-term+)

770

(eql cons-term (symbol-term-id |rdf|:|nil|)))

771

cons-term

772

(rdf-match-object :s cons-term :p (symbol-term-id |rdf|:|rest|))))

773

774

(defun rdf-nthcdr (index cons-term)

775

(let ((nil-term (symbol-term-id |rdf|:|nil|)))

776

(labels ((rdf-nthcdr-aux (index cons-term)

777

(if (or (not (plusp index))

778

(eql cons-term nil-term)

779

(eql cons-term +null-term-id+))

780

cons-term

781

(rdf-nthcdr-aux (1- index) (rdf-rest cons-term)))))

782

(rdf-nthcdr-aux index cons-term))))

783

784

(defun rdf-last (cons-term &optional (index 1))

785

(loop with nil-term = (symbol-term-id |rdf|:|nil|)

786

with cells = (list cons-term)

787

do (setf cons-term (rdf-rest cons-term)

788

cells (cons cons-term cells))

789

until (or (eql cons-term nil-term)

790

(eql cons-term +null-term-id+))

791

finally (return (or (nth index cells) nil-term))))

792

793

794

(defun |lisp|:|first| (resource)

795

"Return the cons cell first object or the null term if either the resource does not

796

exist or matches no such assertion."

797

(let ((cons (rlmdb:value-term-number resource :if-does-not-exist nil)))

798

(if cons

799

(rlmdb:term-number-value (rdf-first cons))

800

(symbol-term-id |rdf|:|nil|))))

801

802

(defun |lisp|:|rest| (resource)

803

"Return the cons cell rest object or the null term if either the resource does not

804

exist or matches no such assertion."

805

(let ((cons (rlmdb:value-term-number resource :if-does-not-exist nil)))

806

(if cons

807

(rlmdb:term-number-value (rdf-rest cons))

808

(symbol-term-id |rdf|:|nil|))))

809

810

(defun |lisp|::|nth| (resource index)

811

(let ((nthcdr-term (rdf-nthcdr index (rlmdb:value-term-number resource))))

812

(cond ((eql nthcdr-term (symbol-term-id |rdf|:|nil|))

813

|rdf|:|nil|)

814

((eql nthcdr-term +null-term-id+)

815

(rlmdb:term-number-value +null-term-id+))

816

(t

817

(rlmdb:term-number-value (rdf-match-object :s nthcdr-term

818

                                                            :p (symbol-term-id |rdf|:|first|)))))))

819

820

821

(defun |lisp|:|nthcdr| (index resource)

822

(let ((nthcdr-term (rdf-nthcdr index (rlmdb:value-term-number resource))))

823

(cond ((eql nthcdr-term (symbol-term-id |rdf|:|nil|))

824

|rdf|:|nil|)

825

(t

826

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

827

828

829

(defun |lisp|:|last| (resource &optional (count 0))

830

(let ((last-term (rdf-last (rlmdb:value-term-number resource) count)))

831

(cond ((eql last-term (symbol-term-id |rdf|:|nil|))

832

|rdf|:|nil|)

833

(t

834

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

835

836

837

(defun |lisp|:|member| (resource element)

838

(let ((element-id (rlmdb:value-term-number element)))

839

(if (eql element-id +null-term-id+)

840

|rdf|:|nil|

841

(loop for resource-id = (rlmdb:value-term-number resource)

842

then (rdf-rest resource-id)

843

when (or (eql resource-id (symbol-term-id |rdf|:|nil|))

844

(eql resource-id +null-term-id+))

845

return |rdf|:|nil|

846

when (eql element-id (rdf-match-object :s resource-id

847

                                                  :p (symbol-term-id |rdf|:|first|)))

848

return (rlmdb:term-number-value resource-id)))))

849

850

851

;;; system metadata

852

(defgeneric |dydra|:|documentation| (function)

853

(:documentation "Iff the term binds a function, return its documentation string.

854

If unbound or undocumented, return a zero length string")

855

(:method ((function symbol))

856

(if (and (fboundp function) (symbol-term-id function))

857

(documentation function 'function)

858

""))

859

(:method ((function t))

860

""))

861

862

(defun |dydra|:|build-revision| ()

863

"Return the source version identifier for the active server"

864

*build-revision*)

865

866

(defun |dydra|:|build-timestamp| ()

867

"Return the unix timestamp of the build for the active server"

868

(universal-time-timeline-location (decode-iso-time *build-timestamp*)))

869

870

(defun |dydra|:|build-date-time| ()

871

"Return the dateTime of the build for the active server"

872

(universal-time-date-time (decode-iso-time *build-timestamp*)))

873

874