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

Kind	Covered	All	%
expression	1028	3373	30.5
branch	104	348	29.9

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

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

2

3

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

4

5

(:documentation "object codecs"

6

7

" handling data for system components:

8

- account

9

- repository

10

- user

11

12

 the operative components comprise identifying information and profile information, configuration state, and run-time state.

13

14

the identifying information is in the form of a uri, which serves as the

15

reference identifier in the repository graphs, and the name or names proper, which

16

appear in the uri pattern respective the class:

17

/accounts/:account

18

/accounts/:account/repositories/:repository

19

/users/:user

20

it is stored in the system/system repository, to which the users do not have direct

21

graph-store access.

22

these components are present as slots in the runtime instance directly as name and id.

23

24

the profile information includes values for contacts, affilations and background description.

25

this is stored in the :account/system repository, in the named graph identified for the instance.

26

this is present as slots in a interface resource instance and in the runtime instance (for access

27

information) with necessary delegation to permit operations on the resource instance only.

28

29

the configuration information includes the parameters which govern query processing

30

this is stored in the :account/system repository, in the named graph identified for the instance.

31

it is represented in separate a metadata instance which depends on the operative instance.

32

33

the runtime state includes data such as the statistics and the effective revision id for a

34

repository. it is present in the opeerative instance only.

35

36

interface runtime configuation

37

resource instance

38

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

39

name

40

id

41

access token

42

--------> acl

43

blog

44

company

45

description

46

email

47

family name

48

first name

49

jabber

50

location

51

owner

52

parent

53

password

54

phone

55

region

56

skype

57

host

58

prefixes

59

request time-out

60

skolemization

61

62

the only complication is the acl, which is user controlled and stored in the :account/system,

63

which means accessible for graph-store operations, but must be available as part of the

64

operational run-time instance.

65

in order to implement it, access to instance state must be through accessors rather than

66

direct slot operations in order to implement delegation

67

68

")

69

70

(defclass object-with-metadata ()

71

((metadata

72

:initform nil :initarg :metadata

73

:reader instance-metadata :writer setf-instance-metadata

74

:documentation "The configuration meta-data for a run-time object is extracted from persistent

75

storage on-demand and cached here for use, eg. to compute entailed queries.")))

76

77

(defmethod log-metadata (message (object object-with-metadata))

78

     (log-debug "~a  ~a: ~s" message (with-output-to-string (stream) (print-unreadable-object (object stream :identity t))) object)

79

(log-metadata (format nil "~a ->" (type-of object)) (instance-metadata object)))

80

81

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

82

((statements

83

:initform nil

84

:reader get-instance-metadata-statements :writer setf-instance-metadata-statements

85

:documentation "The metadata, as collected from the respective repositories,

86

in the forms of a quad sequence. Thos settings which are reflected in the

87

metadata instance will have been carried over when it was instantiated, but

88

aspects such the list of repository identifiers or the authorization spec

89

are left in their literal form until they are required."))

90

(:metaclass persistent-class))

91

92

93

(defclass metadata (persistent-object)

94

((parent

95

:initarg :parent :initform nil

96

:accessor metadata-parent)

97

(resource

98

:initarg :resource :initform nil

99

:reader metadata-resource)

100

(api-key

101

:initarg :api-key

102

:reader get-metadata-api-key :writer (setf metadata-api-key)

103

:documentation "When a task requires authorized access, its capabilities are

104

identified by this key. The value can be specified from the command-line for

105

query-specific processes, or adopted from a request header.")

106

(base-iri

107

:initarg :base-iri

108

:type iri

109

:reader get-metadata-base-iri :writer (setf metadata-base-iri)

110

:property |urn:dydra|:|baseIRI|)

111

(blank-node-prefix

112

:initarg :blank-node-prefix

113

:reader get-metadata-blank-node-prefix :writer (setf metadata-blank-node-prefix)

114

:property |urn:dydra|:|skolemizePrefix|)

115

(blank-node-skolemize

116

:initarg :blank-node-skolemize

117

:type skolemize-mode

118

:reader get-metadata-blank-node-skolemize :writer (setf metadata-blank-node-skolemize)

119

:property |urn:dydra|:|skolemize|)

120

(default-context-term

121

:initarg :default-context-term

122

:type context-term

123

:reader get-metadata-default-context-term :writer (setf metadata-default-context-term)

124

:property |urn:dydra|:|defaultContextTerm|

125

:documentation "The default context to use in queries to the repository.

126

The default value is determined based on *default-context-term*.")

127

(describe-form

128

:initarg :describe-form

129

:type describe-form

130

:reader get-metadata-describe-form :writer (setf metadata-describe-form)

131

:property |urn:dydra|:|describeForm|

132

:documentation "The bounded description form")

133

(describe-object-depth

134

:initarg :describe-object-depth

135

:type (or (integer 0) null)

136

:reader get-metadata-describe-object-depth :writer (setf metadata-describe-object-depth)

137

:property |urn:dydra|:|describeObjectDepth|

138

:documentation "the bounded description subject->object traversal depth")

139

(describe-subject-depth

140

:initarg :describe-subject-depth

141

:type (or (integer 0) null)

142

:reader get-metadata-describe-subject-depth :writer (setf metadata-describe-subject-depth)

143

:property |urn:dydra|:|describeSubjectDepth|

144

:documentation "the bounded description object->subject traversal depth")

145

(entailment-regime

146

;; as a place-holder for when they are supported

147

:initarg :entailment-regime

148

:type iri

149

:reader get-metadata-entailment-regime :writer (setf metadata-entailment-regime))

150

(federation-mode

151

:initarg :federation-mode

152

:type federation-mode

153

:property |urn:dydra|:|federationMode|

154

:reader get-metadata-federation-mode :writer (setf metadata-federation-mode)

155

:documentation "Specifies whether federation is enable and, if so, the form -

156

either internal or external.")

157

(import-limit

158

:initarg :import-limit

159

:type (integer 0)

160

:reader get-metadata-import-limit :writer (setf metadata-import-limit))

161

(memory-limit

162

:initarg :memory-limit

163

:type (integer 0)

164

:reader get-metadata-memory-limit :writer (setf metadata-memory-limit)

165

:property |urn:dydra|:|requestMemoryLimit|)

166

(named-contexts-term

167

:initarg :named-contexts-term

168

:type context-term

169

:reader get-metadata-named-contexts-term :writer (setf metadata-named-contexts-term)

170

:property |urn:dydra|:|namedContextsTerm|

171

:documentation "The named contexts designator to use in queries to the repository.

172

The default value is determined based on *named-contexts-term*.")

173

(namespace-bindings

174

:initarg :namespace-bindings

175

:type list

176

:reader get-metadata-namespace-bindings :writer (setf metadata-namespace-bindings)

177

:property |urn:dydra|:|prefixes|)

178

(operation-limit

179

:initarg :operation-limit

180

:type (integer 0)

181

:reader get-metadata-operation-limit :writer (setf metadata-operation-limit))

182

(provenance-repository-id

183

:initarg :provenance-repository-id

184

:type string

185

:reader get-metadata-provenance-repository-id :writer (setf metadata-provenance-repository-id)

186

:property |urn:dydra|:|provenanceRepositoryId|)

187

(response-limit

188

:initarg :response-limit

189

:type (integer 0)

190

:reader get-metadata-response-limit :writer (setf metadata-response-limit))

191

(response-offset

192

:initarg :response-offset

193

:type (integer 0)

194

:reader get-metadata-response-offset :writer (setf metadata-response-offset))

195

(library-path

196

:initarg :library-path

197

:type iri-list

198

:reader get-metadata-library-path :writer (setf metadata-library-path)

199

:property |urn:dydra|:|libraryPath|)

200

(solution-limit

201

:type (integer 0)

202

:initarg :solution-limit

203

:reader get-metadata-solution-limit :writer (setf metadata-solution-limit)

204

:property |urn:dydra|:|requestSolutionLimit|)

205

(strict-vocabulary-terms

206

:initarg :strict-vocabulary-terms

207

:type boolean

208

:reader get-metadata-strict-vocabulary-terms :writer (setf metadata-strict-vocabulary-terms)

209

:property |urn:dydra|:|strictVocabularyTerms|)

210

(time-limit

211

:initarg :time-limit

212

:type (integer 0)

213

:reader get-metadata-time-limit :writer (setf metadata-time-limit)

214

:property |urn:dydra|:|requestTimeLimit|)

215

(undefined-variable-behavior

216

:initarg :undefined-variable-behavior

217

:type undefined-variable-behavior

218

:reader get-metadata-undefined-variable-behavior :writer (setf metadata-undefined-variable-behavior)

219

:property |urn:dydra|:|undefinedVariableBehavior|))

220

(:documentation

221

"Encapsulate the properties which govern query execution.

222

      Each run-time entity binds its own instance, which, in the case of accounts and repositories, is loaded

223

      from the respective */system metadata repository. The repository instance inherits the configuration

224

      from the account in that it starts as its clone, while the account instance derives from the global

225

      configuration in the same manner. The global configuration combinaes initial values with those loaded

226

from the initialization configuration file. There is no provision for user-scope configuration.

227

228

A distinction eixists between those settings which are necessarily inherited and those which

229

can be specified for an account or repository, in that the latter are associated with

230

codec properties for the store and for presentations, which enables the transfer through those

231

two interfaces, which those wihtout properties are strictly inherited from the initialization

232

configuration.

233

234

A further restriction exists in that some writers constrain their values to permit only those

235

changes which are more restrictive, for example time or solution count limits.")

236

(:metaclass persistent-class))

237

238

(defmethod log-metadata (message (object metadata))

239

   (log-debug "~a ~a: ~s" message (with-output-to-string (stream) (print-unreadable-object (object stream :identity t))) object))

240

241

242

(macrolet ((def-metadata-writers (slot-name &key (type nil))

243

(let ((accessor-name (cons-symbol :spocq.i :metadata- slot-name)))

244

(labels ((generate-methods (type) ;; extra type-specific methods

245

(etypecase type

246

((cons (eql or))

247

                              `((progn ,@(loop for type in (rest type) append (generate-methods type)))))

248

                             ((eql iri) `((defmethod (setf ,accessor-name) ((state string) (metadata metadata))

249

                                            (setf (,accessor-name metadata)

250

                                                  (intern-iri (if (eql (char state 0) #\<)

251

                                                                  (subseq state 0 (1- (length state)))

252

                                                                  state))))))

253

                             ((eql integer) `((defmethod (setf ,accessor-name) ((state string) (metadata metadata))

254

                                                (setf (,accessor-name metadata) (parse-integer state)))))

255

                             ((eql boolean) `((defmethod (setf ,accessor-name) ((state string) (metadata metadata))

256

                                                (setf (,accessor-name metadata)

257

                                                      (cond ((string-equal state "true") t)

258

                                                            ((string-equal state "false") nil)

259

                                                            (t (error "invalid boolean value: ~s" state)))))

260

                                              (defmethod (setf ,accessor-name) ((state spocq:boolean) (metadata metadata))

261

                                                (cond ((equalp state spocq.a:|true|)

262

                                                       (setf (,accessor-name metadata) t))

263

                                                      ((equalp state spocq.a:|false|)

264

                                                       (setf (,accessor-name metadata) nil))

265

(t

266

                                                       (error "invalid boolean value: ~s" state))))))

267

                             ((eql prefix-string) `((defmethod (setf ,accessor-name) ((state string) (metadata metadata))

268

                                                      (setf (,accessor-name metadata)

269

                                                            (decode-configuration-parameter state :prefixes)))))

270

((eql string) nil) ; nothing extra necessary

271

((eql null) nil) ; nothing extra necessary

272

                             ((eql iri-list) `((defmethod (setf ,accessor-name) ((state string) (metadata metadata))

273

                                                (setf (,accessor-name metadata) (iri-sequence-value state)))))

274

(null nil))))

275

`(progn ,@(generate-methods type)

276

                     (defmethod (setf ,accessor-name) ((value (eql '|rdf|:|nil|)) (metadata metadata))

277

(slot-makunbound metadata ',slot-name)))))))

278

279

(def-metadata-writers api-key :type (or string null))

280

(def-metadata-writers base-iri :type (or iri null))

281

(def-metadata-writers blank-node-prefix :type (or string null))

282

(def-metadata-writers blank-node-skolemize :type (or boolean null))

283

(def-metadata-writers default-context-term :type (or iri null))

284

(def-metadata-writers describe-form :type (or iri null))

285

(def-metadata-writers describe-object-depth :type (or integer null))

286

(def-metadata-writers describe-subject-depth :type (or integer null))

287

(def-metadata-writers entailment-regime :type (or iri null))

288

(def-metadata-writers federation-mode :type (or iri null))

289

(def-metadata-writers import-limit :type (or integer null))

290

(def-metadata-writers library-path :type (or iri-list null))

291

(def-metadata-writers memory-limit :type (or integer null))

292

(def-metadata-writers named-contexts-term :type iri)

293

(def-metadata-writers namespace-bindings :type prefix-string)

294

(def-metadata-writers operation-limit :type (or integer null))

295

(def-metadata-writers provenance-repository-id :type string)

296

(def-metadata-writers response-limit :type (or integer null))

297

(def-metadata-writers response-offset :type (or integer null))

298

(def-metadata-writers solution-limit :type (or integer null))

299

(def-metadata-writers strict-vocabulary-terms :type (or boolean null))

300

(def-metadata-writers time-limit :type (or integer null))

301

(def-metadata-writers undefined-variable-behavior :type (or iri null)))

302

303

(defmethod (setf metadata-blank-node-skolemize) ((value string) (metadata metadata))

304

(setf (metadata-blank-node-skolemize metadata) (skolemize-mode-value value)))

305

306

(defmethod (setf metadata-default-context-term) ((value string) (metadata metadata))

307

(setf (metadata-default-context-term metadata) (context-term-value value)))

308

309

(defmethod (setf metadata-describe-form) ((value string) (metadata metadata))

310

(setf (metadata-describe-form metadata) (describe-form-value value)))

311

312

(defmethod (setf metadata-federation-mode) ((value string) (metadata metadata))

313

(setf (metadata-federation-mode metadata) (federation-mode-value value)))

314

315

(defmethod (setf metadata-library-path) ((value string) (metadata metadata))

316

(setf (metadata-library-path metadata) (iri-sequence-value value)))

317

318

(defmethod (setf metadata-named-context-term) ((value string) (metadata metadata))

319

(setf (metadata-named-context-term metadata) (context-term-value value)))

320

321

(defmethod (setf metadata-undefined-variable-behavior) ((value string) (metadata metadata))

322

(setf (metadata-undefined-variable-behavior metadata) (undefined-variable-behavior-value value)))

323

324

325

(defclass system-metadata (metadata)

326

()

327

(:metaclass persistent-class)

328

(:documentation "The system-metadata distinguishes those metada instances which pertain to system

329

accounts and repositories. These are distinguished by being compiled into the run-time

330

and detached from the store."))

331

332

(defmethod resource-synchronized-p ((resource system-metadata))

333

;; as it is static, always true

334

t)

335

336

(defmethod synchronize-resource :around ((resource system-metadata))

337

resource)

338

339

(defclass account-metadata (metadata)

340

()

341

(:metaclass persistent-class))

342

343

(defclass system-account-metadata (system-metadata account-metadata)

344

()

345

(:metaclass persistent-class))

346

347

(defclass repository-metadata (account-metadata)

348

((type-declarations

349

:initform nil :initarg :type-declarations

350

:accessor repository-metadata-type-declarations :accessor metadata-type-declarations))

351

(:metaclass persistent-class))

352

353

(defclass system-repository-metadata (system-metadata repository-metadata)

354

()

355

(:metaclass persistent-class))

356

357

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

358

                                 &key resource (identifier (when resource (instance-identifier resource))))

359

;; adopt the identifier from the concrete resource

360

(apply #'call-next-method instance

361

:identifier identifier

362

initargs))

363

364

(defmethod print-object ((object metadata) stream)

365

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

366

(let ((resource (bound-slot-value object 'resource "#<unbound>")))

367

(format stream " -> ~a" resource))))

368

369

(defun metadata-p (object)

370

(typep object 'metadata))

371

372

373

(defmethod initialize-clone ((old metadata) (new metadata) &rest args &key

374

(parent (_slot-value old 'parent))

375

(resource (_slot-value old 'resource))

376

(api-key (_slot-value old 'api-key old))

377

(base-iri (_slot-value old 'base-iri old))

378

                              (blank-node-prefix (_slot-value old 'blank-node-prefix old))

379

                              (blank-node-skolemize (_slot-value old 'blank-node-skolemize old))

380

                              (default-context-term (_slot-value old 'default-context-term old))

381

(describe-form (_slot-value old 'describe-form old))

382

                              (describe-object-depth (_slot-value old 'describe-object-depth old))

383

                              (describe-subject-depth (_slot-value old 'describe-subject-depth old))

384

                              (entailment-regime (_slot-value old 'entailment-regime old))

385

(federation-mode (_slot-value old 'federation-mode old))

386

(import-limit (_slot-value old 'import-limit old))

387

(memory-limit (_slot-value old 'memory-limit old))

388

                              (named-contexts-term (_slot-value old 'named-contexts-term old))

389

                              (namespace-bindings (_slot-value old 'namespace-bindings old))

390

(operation-limit (_slot-value old 'operation-limit old))

391

                              (provenance-repository-id (_slot-value old 'provenance-repository-id old))

392

(response-limit (_slot-value old 'response-limit old))

393

(response-offset (_slot-value old 'response-offset old))

394

(library-path (_slot-value old 'library-path old))

395

(solution-limit (_slot-value old 'solution-limit old))

396

                              (strict-vocabulary-terms (_slot-value old 'strict-vocabulary-terms old))

397

(time-limit (_slot-value old 'time-limit old))

398

                              (undefined-variable-behavior (_slot-value old 'undefined-variable-behavior old)))

399

(declare (dynamic-extent args))

400

(unless (eq api-key old) (setf (slot-value new 'api-key) api-key))

401

(unless (eq base-iri old) (setf (slot-value new 'base-iri) base-iri))

402

(unless (eq blank-node-prefix old) (setf (slot-value new 'blank-node-prefix) blank-node-prefix))

403

(unless (eq blank-node-skolemize old) (setf (slot-value new 'blank-node-skolemize) blank-node-skolemize))

404

(unless (eq default-context-term old) (setf (slot-value new 'default-context-term) default-context-term))

405

(unless (eq describe-form old) (setf (slot-value new 'describe-form) describe-form))

406

   (unless (eq describe-object-depth old) (setf (slot-value new 'describe-object-depth) describe-object-depth))

407

   (unless (eq describe-subject-depth old) (setf (slot-value new 'describe-subject-depth) describe-subject-depth))

408

(unless (eq entailment-regime old) (setf (slot-value new 'entailment-regime) entailment-regime))

409

(unless (eq federation-mode old) (setf (slot-value new 'federation-mode) federation-mode))

410

(unless (eq import-limit old) (setf (slot-value new 'import-limit) import-limit))

411

(unless (eq memory-limit old) (setf (slot-value new 'memory-limit) memory-limit))

412

(unless (eq named-contexts-term old) (setf (slot-value new 'named-contexts-term) named-contexts-term))

413

(unless (eq namespace-bindings old) (setf (slot-value new 'namespace-bindings) namespace-bindings))

414

(unless (eq operation-limit old) (setf (slot-value new 'operation-limit) operation-limit))

415

   (unless (eq provenance-repository-id old) (setf (slot-value new 'provenance-repository-id) provenance-repository-id))

416

(unless (eq response-limit old) (setf (slot-value new 'response-limit) response-limit))

417

(unless (eq response-offset old) (setf (slot-value new 'response-offset) response-offset))

418

(unless (eq library-path old) (setf (slot-value new 'library-path) library-path))

419

(unless (eq solution-limit old) (setf (slot-value new 'solution-limit) solution-limit))

420

   (unless (eq strict-vocabulary-terms old) (setf (slot-value new 'strict-vocabulary-terms) strict-vocabulary-terms))

421

(unless (eq time-limit old) (setf (slot-value new 'time-limit) time-limit))

422

   (unless (eq undefined-variable-behavior old) (setf (slot-value new 'undefined-variable-behavior) undefined-variable-behavior))

423

(apply #'call-next-method old new

424

:parent parent

425

:resource resource

426

args))

427

428

429

(defmethod decode-presentation-graph ((resource metadata) (graph (eql |rdf|:|nil|)))

430

"GIven a nil indicator, clear the metadata instance back to the hollow state, for the

431

purpose to eliminate all local state and cause the parent state to apply for everything."

432

(unbind-resource resource))

433

434

435

(defun make-metadata (&rest args)

436

(declare (dynamic-extent args))

437

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

438

439

(defmethod instance-repository-id ((instance metadata))

440

(instance-repository-id (metadata-resource instance)))

441

442

(defmethod compute-resource-store-repository-id ((metadata metadata))

443

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

444

445

(defun account-metadata-p (object)

446

(typep object 'account-metadata))

447

448

(defun make-account-metadata (&rest args)

449

(declare (dynamic-extent args))

450

(apply #'make-instance 'account-metadata

451

:parent nil

452

args))

453

454

(defun make-system-account-metadata (&key (resource nil))

455

;; allow to defer until after configuration has been loaded

456

(let ((md (make-instance 'system-account-metadata

457

:resource resource

458

:api-key *system-api-key*

459

:base-iri (base-iri)

460

:blank-node-prefix nil

461

:blank-node-skolemize nil

462

:default-context-term |urn:dydra|:|default|

463

:describe-form |urn:dydra|:|simple-symmetric-concise-bounded-description|

464

:describe-object-depth 1

465

:describe-subject-depth 1

466

:entailment-regime nil

467

:federation-mode nil

468

:import-limit nil ; no limit for the system account

469

:memory-limit nil ; no limit for the system account

470

:named-contexts-term |urn:dydra|:|named|

471

:namespace-bindings (namespace-bindings)

472

:operation-limit (operation-limit)

473

:provenance-repository-id nil

474

:response-limit nil

475

:response-offset 0

476

:library-path ()

477

:solution-limit nil

478

:time-limit nil

479

:undefined-variable-behavior |urn:dydra|:|error|)))

480

(setf (instance-state md) :detached)

481

(setf (resource-store-repository-id md) *system-repository-id*)

482

md))

483

484

485

486

(defun repository-metadata-p (object)

487

(typep object 'repository-metadata))

488

489

(defun make-repository-metadata (&rest args &key repository &allow-other-keys)

490

"create a metadata cache for the repository which inherits from the account's"

491

(declare (dynamic-extent args))

492

(apply #'make-instance 'repository-metadata

493

:parent (when repository (instance-metadata (repository-account repository)))

494

args))

495

496

(defun make-system-repository-metadata (&key (resource nil))

497

;; allow to defer until after configuration has been loaded

498

(let ((md (make-instance 'system-repository-metadata

499

:resource resource

500

:parent nil

501

:api-key *system-api-key*

502

:base-iri (base-iri)

503

:blank-node-prefix nil

504

:blank-node-skolemize nil

505

:default-context-term |urn:dydra|:|default|

506

:describe-form |urn:dydra|:|simple-symmetric-concise-bounded-description|

507

:describe-object-depth 1

508

:describe-subject-depth 1

509

:entailment-regime nil

510

:federation-mode nil

511

:import-limit nil ; no limit for the system account

512

:memory-limit nil ; no limit for the system account

513

:named-contexts-term |urn:dydra|:|named|

514

:namespace-bindings (namespace-bindings)

515

:operation-limit (operation-limit)

516

:provenance-repository-id nil

517

:response-limit nil

518

:response-offset 0

519

:library-path ()

520

:solution-limit nil

521

:time-limit nil

522

:undefined-variable-behavior |urn:dydra|:|error|)))

523

(setf (instance-state md) :detached)

524

(setf (resource-store-repository-id md) *system-repository-id*)

525

md))

526

527

528

(defmethod encode-presentation-graph ((metadata metadata))

529

(let ((field (call-next-method)))

530

;; encode object values which cannot be encoded as graph terms

531

;; prefix bindings

532

(loop for statement in field

533

for (s p o) = statement

534

collect (case p

535

(|urn:dydra|:|prefixes|

536

(list s p (encode-prefix-parameter o p)))

537

(t statement)))))

538

539

(defmethod encode-store-graph ((metadata metadata))

540

(let ((field (call-next-method)))

541

;; encode object values which cannot be encoded as graph terms

542

;; prefix bindings

543

(loop for statement in field

544

for (s p o) = statement

545

collect (case p

546

(|urn:dydra|:|prefixes|

547

(list s p (encode-prefix-parameter o p)))

548

(t statement)))))

549

550

(defun assert-prototype-metadata (prototype-metadata)

551

;; transfer anything which could have originated from the query text - including pragmas

552

(setf (metadata-base-iri *metadata*) (metadata-base-iri prototype-metadata)

553

(metadata-blank-node-prefix *metadata*) (metadata-blank-node-prefix prototype-metadata)

554

(metadata-blank-node-skolemize *metadata*) (metadata-blank-node-skolemize prototype-metadata)

555

(metadata-default-context-term *metadata*) (metadata-default-context-term prototype-metadata)

556

(metadata-describe-form *metadata*) (metadata-describe-form prototype-metadata)

557

(metadata-describe-object-depth *metadata*) (metadata-describe-object-depth prototype-metadata)

558

(metadata-describe-subject-depth *metadata*) (metadata-describe-subject-depth prototype-metadata)

559

;; not entailment regime, that is deprecated

560

(metadata-federation-mode *metadata*) (metadata-federation-mode prototype-metadata)

561

(metadata-named-contexts-term *metadata*) (metadata-named-contexts-term prototype-metadata)

562

(metadata-namespace-bindings *metadata*) (metadata-namespace-bindings prototype-metadata)

563

;; not response limit and/or offse: they must come from the request, not the clone

564

         (metadata-provenance-repository-id *metadata*) (metadata-provenance-repository-id prototype-metadata)

565

         (metadata-undefined-variable-behavior *metadata*) (metadata-undefined-variable-behavior prototype-metadata)

566

))

567

568

;;;

569

;;; metadata accessors

570

571

(macrolet ((def-metadata-property (name &key (type t) (read-mode :inherit))

572

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

573

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

574

(parameter-name (cons-symbol :spocq.i :* name :*)))

575

(labels ((generate-methods (type)

576

(typecase type

577

((eql integer)

578

`((:method ((value string))

579

(setf (,name) (parse-integer value)))

580

(:method ((value integer))

581

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

582

((cons (eql or))

583

                              (loop for type in (rest type) append (generate-methods type)))

584

(t

585

`((:method ((value ,type))

586

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

587

`(progn (defgeneric ,operator-name (metadata)

588

(:method ((metadata null)) ,parameter-name)

589

                          (:method ((instance object-with-metadata)) (,operator-name (instance-metadata instance)))

590

(:method ((metadata metadata))

591

,(ecase read-mode

592

(:inherit `(if (slot-boundp metadata ',name)

593

                                            (,reader-operator-name metadata)

594

                                            (,operator-name (metadata-parent metadata))))

595

                               (:append `(let ((parent-value (,operator-name (metadata-parent metadata)))

596

                                                    (instance-value (when (slot-boundp metadata ',name)

597

                                                                      (,reader-operator-name metadata))))

598

                                                (append instance-value parent-value)))

599

(:instance `(when (slot-boundp metadata ',name)

600

                                             (,reader-operator-name metadata))))))

601

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

602

(:method (value (metadata null)) (setq ,parameter-name value))

603

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

604

(defun ,name ()

605

(,operator-name *metadata*))

606

(defgeneric (setf ,name) (value)

607

,@(generate-methods type)))))))

608

609

(def-metadata-property api-key :type (or null string))

610

(def-metadata-property base-iri :type (or symbol spocq:iri))

611

(def-metadata-property blank-node-prefix :type (or null string))

612

(def-metadata-property blank-node-skolemize :type symbol)

613

(def-metadata-property default-context-term :type symbol)

614

(def-metadata-property describe-form)

615

(def-metadata-property describe-object-depth :type (or null integer))

616

(def-metadata-property describe-subject-depth :type (or null integer))

617

(def-metadata-property entailment-regime)

618

(def-metadata-property federation-mode)

619

(def-metadata-property import-limit :type (or null integer))

620

(def-metadata-property memory-limit :type (or null integer))

621

(def-metadata-property named-contexts-term :type symbol)

622

(def-metadata-property namespace-bindings :read-mode :append)

623

(def-metadata-property operation-limit :type (or null integer))

624

(def-metadata-property provenance-repository-id)

625

(def-metadata-property response-limit :type integer)

626

(def-metadata-property response-offset :type (or null integer))

627

(def-metadata-property library-path)

628

(def-metadata-property solution-limit :type (or null integer))

629

(def-metadata-property strict-vocabulary-terms)

630

(def-metadata-property time-limit :type (or null integer))

631

(def-metadata-property undefined-variable-behavior))

632

633

634

(defun iri-sequence-value (value)

635

"coerce to a list of iri values"

636

(etypecase value

637

(string (mapcar #'intern-iri (split-string value #(#\space #\return #\linefeed))))

638

(list (mapcar #'intern-iri value))))

639

640

(defun iri-value (value)

641

"coerce to an iri value"

642

(etypecase value

643

(string (when (plusp (length value)) (intern-iri value)))

644

(iri value)

645

(null nil)))

646

647

648

;;; allow to remove the authentication key, but not to change it if present

649

(defmethod (setf api-key) :before ((value string))

650

(let ((old (api-key)))

651

(when old (assert (equalp value old) ()

652

"It is not permitted to change an existing api key."))))

653

654

655

(defmethod (setf base-iri) ((value puri:uri))

656

;; the base iri is a model term as it figures in the sparql parser and the language operators

657

(setf (base-iri) (intern-iri (with-output-to-string (stream) (puri:render-uri value stream)))))

658

(defmethod (setf base-iri) ((value string))

659

     ;; the base iri is a model term as it figures in the sparql parser and the language operators

660

(setf (base-iri) (intern-iri value)))

661

662

(defun skolemize-mode-value (value)

663

(case value

664

((|urn:dydra|:|skolemize-insert| |urn:dydra|:|skolemize-export| |urn:dydra|:|skolemize| nil)

665

value)

666

(t

667

(etypecase value

668

(symbol (abstract-context-value (string value)))

669

(string

670

(if (string-equal "urn:dydra:" value :end2 (min (length value) 10))

671

(skolemize-mode-value (intern-iri value))

672

(or (rest (assoc (remove-if-not #'alpha-char-p value)

673

'(("nil" . nil)

674

("t" . |urn:dydra|:|skolemize|)

675

("skolemize" . |urn:dydra|:|skolemize|)

676

("export" . |urn:dydra|:|skolemize-export|)

677

("skolemizeexport" . |urn:dydra|:|skolemize-export|)

678

("insert" . |urn:dydra|:|skolemize-insert|)

679

("skolemizeinsert" . |urn:dydra|:|skolemize-insert|))

680

:test #'string-equal))

681

(error "Invalid skolemize mode: ~s." value))))))))

682

683

(defmethod (setf blank-node-skolemize) :around ((value symbol))

684

(call-next-method (skolemize-mode-value value)))

685

686

(defmethod (setf blank-node-skolemize) ((value string))

687

(setf (blank-node-skolemize) (skolemize-mode-value value)))

688

689

690

(defmethod (setf blank-node-prefix) :before ((value t))

691

(assert (or (null value)

692

(and (stringp value)

693

(or (zerop (length value))

694

(is-pn_local value))))

695

()

696

"Invalid blank node label syntax: ~s." value))

697

698

(defun abstract-context-value (value)

699

(case value

700

((|urn:dydra|:|all| |urn:dydra|:|default| |urn:dydra|:|named|)

701

value)

702

(t

703

(etypecase value

704

(symbol (abstract-context-value (string value)))

705

(string

706

(if (string-equal "urn:dydra:" value :end2 (min (length value) 10))

707

(abstract-context-value (intern-iri value))

708

(or (rest (assoc value '(("all" . |urn:dydra|:|all|)

709

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

710

("named" . |urn:dydra|:|named|))

711

:test #'string-equal))

712

(error "Invalid abstract context term: ~s." value))))))))

713

714

(defun context-term-value (object)

715

(abstract-context-value object))

716

717

(defmethod (setf default-context-term) :around ((value symbol))

718

(call-next-method (abstract-context-value value)))

719

720

(defmethod (setf default-context-term) ((value string))

721

(setf (default-context-term) (abstract-context-value value)))

722

723

724

(defun describe-form-value (value)

725

"see http://www.w3.org/Submission/CBD/"

726

(case value

727

((|urn:dydra|:|simple-concise-bounded-description|

728

|urn:dydra|:|simple-symmetric-concise-bounded-description|

729

|urn:dydra|:|simple-inverse-concise-bounded-description|)

730

value)

731

(t

732

(etypecase value

733

(symbol (describe-form-value (string value)))

734

(string

735

(if (string-equal "urn:dydra:" value :end2 (min (length value) 10))

736

(describe-form-value (intern-iri value))

737

           (or (rest (assoc value '(("simple-concise-bounded-description" . |urn:dydra|:|simple-concise-bounded-description|)

738

                                    ("assymetric" . |urn:dydra|:|simple-concise-bounded-description|)

739

                                    ("simple-symmetric-concise-bounded-description" . |urn:dydra|:|simple-symmetric-concise-bounded-description|)

740

                                    ("symmetric" . |urn:dydra|:|simple-symmetric-concise-bounded-description|)

741

                                    ("simple-inverse-concise-bounded-description" . |urn:dydra|:|simple-inverse-concise-bounded-description|)

742

                                    ("inverse" . |urn:dydra|:|simple-inverse-concise-bounded-description|))

743

:test #'string-equal))

744

(error "Invalid describe form: ~s." value))))))))

745

746

(defmethod (setf describe-form) :around ((value symbol))

747

(call-next-method (describe-form-value value)))

748

749

(defmethod (setf describe-form) ((value string))

750

(setf (describe-form) (describe-form-value value)))

751

752

753

(defun federation-mode-value (value)

754

(case value

755

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

756

value)

757

(t

758

(etypecase value

759

(symbol (federation-mode-value (string value)))

760

(string

761

(if (string-equal "urn:dydra:" value :end2 (min (length value) 10))

762

(federation-mode-value (intern-iri value))

763

(or (rest (assoc value '(("external" . |urn:dydra|:|external|)

764

("internal" . |urn:dydra|:|internal|)

765

("none" . |urn:dydra|:|none|))

766

:test #'string-equal))

767

(error "Invalid federation mode: ~s." value))))))))

768

769

(defmethod (setf federation-mode) :around ((value symbol))

770

"Set a new federation mode as constrained by the current mode"

771

(let ((old-value (federation-mode)))

772

(flet ((mode-error ()

773

(error "Cannot modify federation mode: ~s to ~s."

774

old-value value)))

775

(setf value (federation-mode-value value))

776

(ecase old-value

777

((nil)) ; permit no setting initially

778

(|urn:dydra|:|none| (mode-error))

779

(|urn:dydra|:|internal| (unless (member value '(|urn:dydra|:|none| |urn:dydra|:|internal|))

780

(mode-error)))

781

(|urn:dydra|:|external|))

782

(call-next-method value))))

783

784

(defmethod (setf federation-mode) ((value string))

785

(setf (federation-mode) (federation-mode-value value)))

786

787

788

(defmethod (setf named-contexts-term) :around ((value symbol))

789

(call-next-method (abstract-context-value value)))

790

791

(defmethod (setf named-contexts-term) ((value string))

792

(setf (named-contexts-term) (abstract-context-value value)))

793

794

795

(defun undefined-variable-behavior-value (value)

796

(case value

797

((|urn:dydra|:|error| |urn:dydra|:|warning| |urn:dydra|:|dynamicBinding|)

798

value)

799

(t

800

(etypecase value

801

(symbol (undefined-variable-behavior-value (string value)))

802

(string

803

(if (string-equal "urn:dydra:" value :end2 (min (length value) 10))

804

(undefined-variable-behavior-value (intern-iri value))

805

(or (rest (assoc value '(("error" . |urn:dydra|:|error|)

806

("warn" . |urn:dydra|:|warning|)

807

("warning" . |urn:dydra|:|warning|)

808

("dynamic" . |urn:dydra|:|dynamicBinding|)

809

                                    ("dynamic-binding" . |urn:dydra|:|dynamicBinding|)

810

("special" . |urn:dydra|:|dynamicBinding|))

811

:test #'string-equal))

812

(error "Invalid undefined variable behavior: ~s." value))))))))

813

814

(defmethod (setf undefined-variable-behavior) :around ((value symbol))

815

(call-next-method (undefined-variable-behavior-value value)))

816

817

(defmethod (setf undefined-variable-behavior) ((value string))

818

(setf (undefined-variable-behavior) (undefined-variable-behavior-value value)))

819

820

821

(defmethod (setf memory-limit) :before ((value null))

822

(assert (null (memory-limit)) ()

823

"It is not permitted to eliminate the memory limit."))

824

825

(defmethod (setf memory-limit) :before ((value integer))

826

(let ((old (memory-limit)))

827

(when old (assert (<= value old) ()

828

                       "It is not permitted to set the memory limit beyond ~d." old))))

829

830

831

(defmethod (setf import-limit) :before ((value null))

832

(assert (null (import-limit)) ()

833

"It is not permitted to eliminate the import limit."))

834

835

(defmethod (setf import-limit) :before ((value integer))

836

(let ((old (import-limit)))

837

(when old (assert (<= value old) ()

838

                       "It is not permitted to set the import limit beyond ~d." old))))

839

840

841

(defmethod (setf operation-limit) :before ((value null))

842

(assert (null (operation-limit)) ()

843

"It is not permitted to eliminate the operation limit."))

844

845

(defmethod (setf operation-limit) :before ((value integer))

846

(let ((old (operation-limit)))

847

(when old (assert (<= value old) ()

848

                       "It is not permitted to set the operation limit beyond ~d." old))))

849

850

#+(or)

851

;;; this prevents raising the limit on successive requests

852

;;; and is nit a useful limit in principle.

853

(defmethod (setf response-limit) :before ((value null))

854

(assert (null (response-limit)) ()

855

"It is not permitted to eliminate the response limit."))

856

857

#+(or)

858

(defmethod (setf response-limit) :before ((value integer))

859

(let ((old (response-limit)))

860

(when old (assert (<= value old) ()

861

                       "It is not permitted to set the response limit beyond ~d." old))))

862

863

864

(defmethod (setf solution-limit) :before ((value null))

865

(assert (null (solution-limit)) ()

866

"It is not permitted to eliminate the solution limit."))

867

868

(defmethod (setf solution-limit) :before ((value integer))

869

(let ((old (solution-limit)))

870

(when old (assert (<= value old) ()

871

                       "It is not permitted to set the solution limit beyond ~d." old))))

872

873

874

(defmethod (setf time-limit) :before ((value null))

875

(assert (null (time-limit)) ()

876

"It is not permitted to eliminate the time limit."))

877

878

(defmethod (setf time-limit) :before ((value integer))

879

(let ((old (time-limit)))

880

(when old (assert (<= value old) ()

881

"It is not permitted to set the time limit beyond ~d." old))))

882

883

884

(defun response-end ()

885

(let ((limit (response-limit))

886

(offset (response-offset)))

887

(if (and limit offset)

888

(+ limit offset)

889

limit)))

890

891

;;;

892

;;; persistence and presentation specifics

893

894

895

;;;

896

;;;

897

898

(defmacro with-instance-metadata ((source &rest args) &body body)

899

`(with-metadata-bound (,source ,@args) ,@body))

900

901

(defmacro with-metadata-bound ((source &rest args) &body body)

902

(let ((op (gensym "instance-metadata-op-")))

903

`(flet ((,op () ,@body))

904

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

905

;; allow either a static keyword argument list or one concluded by a variable

906

,(if (evenp (length args))

907

`(call-with-metadata-bound #',op ,source ,@args)

908

`(apply #'call-with-metadata-bound #',op ,source ,@args)))))

909

910

(defgeneric call-with-metadata-bound (op source &rest args)

911

   (:documentation "create a dynamic contour with the standard processing metadata rebound. given additional

912

arguments, bind instead a new metadata instance clone as modified with those arguments.

913

execute the given function and return its value(s). any changes to the settings are written

914

through to the original unless ithas been clonsed.")

915

916

(:method (op (metadata metadata) &rest args)

917

(declare (dynamic-extent args))

918

(let ((*metadata* (if args

919

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

920

metadata)))

921

(funcall op)))

922

923

(:method (op (source null) &rest args)

924

(call-with-metadata-bound op (apply #'make-metadata :allow-other-keys t args))))

925

926

927

(defgeneric parse-dynamic-bindings (bindings)

928

(:method ((string string))

929

(let ((*package* *variable-package*))

930

(parse-dynamic-bindings (with-standard-io-syntax (read-from-string string)))))

931

932

(:method ((bindings cons))

933

(let ((variables (loop for name in (first bindings)

934

                        collect (if (and (symbolp name) (eq (symbol-package name) *variable-package*))

935

name

936

(intern (string name) *variable-package*)))))

937

(cons variables

938

(loop for value in (rest bindings)

939

for variable in variables

940

collect (typecase value

941

(string (parse-dynamic-binding variable value))

942

(t value))))))

943

(:method ((value null))

944

nil))

945

946

(defgeneric parse-dynamic-binding (variable value)

947

(:documentation "perform binding-specific parsing. most are a ntriples terms, but some are constant.")

948

(:method ((variable t) (value string))

949

(handler-case (parse-term value)

950

(error (c) (log-warn "invalid dynamic binding: ~a: ~s: ~a" variable value c)

951

(spocq:make-unbound-variable variable))))

952

(:method ((variable t) (value t))

953

value)

954

(:method ((variable (eql '?::|query|)) (value string))

955

value))

956

957

958

(defgeneric parse-tpf-bindings (bindings)

959

(:method ((string string))

960

(let ((*package* *variable-package*))

961

(parse-tpf-bindings (with-standard-io-syntax (read-from-string string)))))

962

963

(:method ((bindings cons))

964

(let ((variables (loop for name in (first bindings)

965

                        collect (if (and (symbolp name) (eq (symbol-package name) *variable-package*))

966

name

967

(intern (string name) *variable-package*)))))

968

(cons variables

969

(loop for value in (rest bindings)

970

for variable in variables

971

collect (typecase value

972

(string (parse-tpf-term variable value))

973

(t value))))))

974

(:method ((value null))

975

nil))

976

977

(defun parse-tpf-iri (value)

978

(when (plusp (length value))

979

     (cond ((and (> (length value) 2) (eql (char value 0) #\<) (eql (char value (1- (length value))) #\>))

980

(intern-iri (subseq value 1 (1- (length value)))))

981

(t

982

(intern-iri value)))))

983

984

(defun parse-tpf-blank-node (value)

985

(when (is-blank_node value)

986

(intern-blank-node (subseq value 2))))

987

988

(defgeneric parse-tpf-term (variable value)

989

(:documentation "parse a triple-pattern-fragment template term with constraints as per the variable")

990

(:method ((variable (eql '?::|graph|)) (value string))

991

(unless (zerop (length value))

992

(or (parse-tpf-blank-node value) (parse-tpf-iri value)

993

(error "parse-tpf-term: invalid value: ~s" value))))

994

(:method ((variable (eql '?::|c|)) (value t))

995

(parse-tpf-term '?::|graph| value))

996

(:method ((variable (eql '?::|context|)) (value t))

997

(parse-tpf-term '?::|graph| value))

998

999

(:method ((variable symbol) (value string))

1000

(unless (zerop (length value))

1001

(cond ((eql (char value 0) #\?)

1002

(if (> (length value) 1)

1003

(make-variable (subseq value 1))

1004

(error "parse-tpf-term: invalid value: ~s" value)))

1005

((eql (char value 0) #\2)

1006

(handler-case (parse-term value)

1007

                (error (c) (declare (ignore c)) (error "parse-tpf-term: invalid value: ~s" value))))

1008

((parse-tpf-blank-node value))

1009

;; anything else is an iri

1010

((parse-tpf-iri value)))))

1011

1012

(:method ((variable string) (value t))

1013

(parse-tpf-term (or (find-symbol variable *variable-package*)

1014

(error "parse-tpf-term: invalid variable: ~s" variable))

1015

value)))

1016

1017

1018

;;;

1019

;;; environment variable handling

1020

1021

(defparameter *query-parameter-scanner*

1022

(cl-ppcre:create-scanner '(:sequence (:register (:greedy-repetition 1 nil (:inverted-char-class #\= #\&)))

1023

(:GREEDY-REPETITION 0 1 (:sequence #\=

1024

                                                                 (:GREEDY-REPETITION 0 nil :whitespace-char-class)

1025

                                                                 (:register (:GREEDY-REPETITION 0 1 (:greedy-repetition 1 nil (:inverted-char-class #\&))))

1026

                                                                 (:GREEDY-REPETITION 0 1 #\&)

1027

                                                                 (:GREEDY-REPETITION 0 nil :whitespace-char-class))))))

1028

1029

1030

(flet ((date-time-value (value)

1031

(etypecase value

1032

(spocq:date-time value)

1033

(string (when (plusp (length value)) (spocq.e:date-time value)))

1034

(integer (spocq.e:date-time value))

1035

(null value)))

1036

(rfc1123-time-value (value)

1037

(etypecase value

1038

(spocq:date-time (date-time-universal-time value))

1039

(string (when (plusp (length value))

1040

(parse-rfc1123 value :junk-allowed t)))

1041

(integer value)

1042

(null value)))

1043

(universal-time-value (value)

1044

(etypecase value

1045

(spocq:date-time (date-time-universal-time value))

1046

            (string (when (plusp (length value)) (date-time-universal-time (spocq.e:date-time value))))

1047

(integer value)

1048

(null value)))

1049

(integer-value (value)

1050

(etypecase value

1051

(string (when (plusp (length value)) (parse-integer value)))

1052

(integer value)

1053

(null value)))

1054

(iri-bindings-value (value)

1055

(etypecase value

1056

(string (loop for (prefix . iri) in (read-from-string

1057

                                                 (if (eql (char value 0) #\()

1058

value

1059

                                                   (concatenate 'string "(" value ")")))

1060

collect (cons prefix

1061

(etypecase iri

1062

(string (intern-iri iri))

1063

                                          (cons (intern-iri (first iri)))))))

1064

(list value)))

1065

(pnlocal-value (value)

1066

(etypecase value

1067

(string (or (zerop (length value))

1068

                        (assert (is-pn_local value) () "Invalid blank node label syntax: ~s." value))

1069

value)

1070

(null value)))

1071

(mime-type-value (value)

1072

(etypecase value

1073

(string (when (plusp (length value)) (mime-type value)))

1074

(mime-type value)

1075

(null nil))))

1076

1077

(defun canonicalize-argument-list (argument-list)

1078

     "Accept a property list which collects the literal values passed through one of the invocation interfaces

1079

      (amqp, cli, uri query string, or an http request a-list) coerce each name to its respective canonical

1080

keyword and parse and intern the respective argument values."

1081

(let ((dataset (list :default-graphs nil :named-graphs nil)))

1082

(labels ((canonicalize-argument (key value)

1083

(case (etypecase key

1084

                          (string (setf key (intern (nsubstitute #\- #\_ (string-upcase key)) :keyword)))

1085

(keyword key))

1086

(:accept-datetime

1087

(when (or (getf argument-list :revision-start-time)

1088

(getf argument-list :revision-end-time))

1089

                       (spocq.e:request-error "one only of start, end, or accept date-time may appear: ~s." argument-list))

1090

(multiple-value-bind (repository revision)

1091

                                          (apply #'repository-find-revision (or (getf argument-list :repository-id)

1092

                                                                     (getf argument-list :repository)

1093

                                                                     (spocq.e:request-error "repository or repository-id must appear: ~s." argument-list))

1094

                                                 :revision-start-time (or (rfc1123-time-value value)

1095

                                                                          (spocq.e:request-error "the accept-datetime must be a valid rfc1123-date: ~s." argument-list))

1096

argument-list)

1097

`(:repository ,repository :revision-id ,revision)))

1098

(:agent-id

1099

`(:agent-id ,value))

1100

((:agent-location :request-ip-address)

1101

`(:agent-location ,value))

1102

((:|api_key| :api-key :apikey)

1103

`(:api-key ,value))

1104

((:base-iri :base :baseiri)

1105

`(:base-iri ,(iri-value value)))

1106

                    ((:blank-node-prefix :skolemize-prefix) `(:blank-node-prefix ,(pnlocal-value value)))

1107

                    ((:blank-node-skolemize :skolemize) `(:blank-node-skolemize ,(skolemize-mode-value value)))

1108

(:dataset-graphs

1109

(loop for (key graphs) on value by #'cddr

1110

do (ecase key

1111

                                (:named-graphs (setf (dataset-named-graphs dataset) (iri-sequence-value graphs)))

1112

                                (:default-graphs (setf (dataset-default-graphs dataset) (iri-sequence-value graphs)))))

1113

nil)

1114

                    (:default-context-term `(:default-context-term ,(abstract-context-value value)))

1115

(:default-graphs

1116

(setf (dataset-default-graphs dataset)

1117

                            (append (dataset-default-graphs dataset) (iri-sequence-value value)))

1118

nil)

1119

(:describe-form `(:describe-form ,(describe-form-value value)))

1120

(:describe-object-depth `(:describe-object-depth ,(integer-value value)))

1121

(:describe-subject-depth `(:describe-subject-depth ,(integer-value value)))

1122

(:dynamic-bindings `(:dynamic-bindings ,(parse-dynamic-bindings value)))

1123

(:end-time `(:end-time ,(universal-time-value value)))

1124

(:federation-mode `(:federation-mode ,(federation-mode-value value)))

1125

(:import-limit `(:import-limit ,(integer-value value )))

1126

(:library-path `(:library-path ,(iri-sequence-value value)))

1127

(:memory-limit `(:memory-limit ,(integer-value value )))

1128

                    (:named-contexts-term `(:named-contexts-term ,(abstract-context-value value)))

1129

((:named-graphs :named-graph-uri)

1130

(setf (dataset-named-graphs dataset)

1131

                           (append (dataset-named-graphs dataset) (iri-sequence-value value)))

1132

nil)

1133

;; any new prefix binding adds to those already known

1134

                    (:namespace-bindings `(:namespace-bindings ,(append (iri-bindings-value value) *namespace-bindings*)))

1135

(:operation `(:operation ,value))

1136

(:operation-limit `(:operation-limit ,(integer-value value )))

1137

                    ((:provenance-repository :provenance-repository-id) `(:provenance-repository-id ,value))

1138

((:signature :query-signature) `(:query-signature ,value))

1139

(:repository `(:repository (repository ,value)))

1140

(:repository-id `(:repository-id ,value))

1141

                    ((:request-content-type :content-type :query-content-type) `(:request-content-type ,(mime-type-value value)))

1142

;; if negotiation is involved, do not convert this into a mime type.

1143

                    ;; the negotiation can be context dependent based on the resource, which logic is present in a server only

1144

((:response-content-type :accept)

1145

                     `(:response-content-type ,(if (position #\, value) value (mime-type-value value))))

1146

                    ((:response-limit :limit :query-limit) `(:response-limit ,(integer-value value)))

1147

                    ((:response-offset :offset :query-offset) `(:response-offset ,(integer-value value)))

1148

((:revision-id :revision-uuid) `(:revision-id ,value))

1149

(:request-routing-key `(:request-routing-key ,value))

1150

((:request-exchange :exchange) `(:request-exchange ,value))

1151

(:start-time `(:start-time ,(universal-time-value value)))

1152

((:task-id :query-id) `(:task-id ,value))

1153

(:time-interval `(:time-interval ,(integer-value value)))

1154

(:time-limit `(:time-limit ,(integer-value value)))

1155

(:tpf-bindings `(:dynamic-bindings ,(parse-tpf-bindings value)))

1156

(:trace-routing-key `(:trace-routing-key ,value))

1157

                    (:undefined-variable-behavior `(:undefined-variable-behavior ,(undefined-variable-behavior-value value)))

1158

(:user-id `(:user-id ,value))

1159

((:values :values-data :request-values) `(:request-values ,(etypecase value

1160

                                                                                 (string (list (parse-values-data value)))

1161

                                                                                 (list (loop for value in value

1162

                                                                                         collect (etypecase value

1163

                                                                                                   (string (parse-values-data value))

1164

                                                                                                   (cons value)))))))

1165

1166

                    ;; temporal constraints: permit one only, until it is possible to compose revisions

1167

(:revision-end-time

1168

;; latest intersection with the interval [nil revision-end-time)

1169

(when (or (getf argument-list :revision-start-time)

1170

(getf argument-list :accept-datetime))

1171

                       (spocq.e:request-error "one only of start, end, or accept date-time may appear: ~s." argument-list))

1172

(multiple-value-bind (repository revision)

1173

                                          (apply #'repository-find-revision (or (getf argument-list :repository-id)

1174

                                                                     (getf argument-list :repository)

1175

                                                                     (spocq.e:request-error "repository or repository-id must appear: ~s." argument-list))

1176

                                                 :revision-end-time (universal-time-value value) argument-list)

1177

`(:repository ,repository :revision ,revision)))

1178

(:revision-start-time

1179

;; earliest intersection with the interval [revision-start-time nil)

1180

(when (or (getf argument-list :revision-end-time)

1181

(getf argument-list :accept-datetime))

1182

                       (spocq.e:request-error "one only of start, end, or accept date-time may appear: ~s." argument-list))

1183

(multiple-value-bind (repository revision)

1184

                                          (apply #'repository-find-revision (or (getf argument-list :repository-id)

1185

                                                                     (getf argument-list :repository)

1186

                                                                     (spocq.e:request-error "repository or repository-id must appear: ~s." argument-list))

1187

                                                 :revision-start-time (universal-time-value value) argument-list)

1188

`(:repository ,repository :revision ,revision)))

1189

1190

;; permit unknowns, as-is

1191

(t (canonicalize-configuration-argument key value)))))

1192

(append (loop for (key value) on argument-list by #'cddr

1193

when (plusp (length value))

1194

append (canonicalize-argument key value))

1195

(when (or (dataset-default-graphs dataset) (dataset-named-graphs dataset))

1196

`(:dataset-graphs ,dataset)))))))

1197

1198

(defgeneric canonicalize-configuration-argument (key value)

1199

(:documentation "Extend canonicalize-argument-list with argument-specific

1200

methods to canonicalize the respective value type.

1201

The default method returns the (key value) list as-is.")

1202

(:method ((key t) (value t))

1203

(list key value)))

1204

1205

(defun parse-query-parameters (string)

1206

(when (find #\% string)

1207

(setf string (puri::decode-escaped-encoding string t nil)))

1208

(let ((argument-list ()))

1209

(cl-ppcre:do-scans (binding-start bindings-end starts ends *query-parameter-scanner* string)

1210

(push (subseq string (aref starts 0) (aref ends 0)) argument-list)

1211

       (push (when (and (aref starts 1) (> (aref ends 1) (aref starts 1))) (subseq string (aref starts 1) (aref ends 1))) argument-list))

1212

(canonicalize-argument-list (nreverse argument-list))))

1213

1214

;; (parse-query-parameters (sb-posix:getenv "QUERY_STRING"))

1215

;; (parse-query-parameters "start-time")

1216

;; (parse-query-parameters "start-time=")

1217

;; (parse-query-parameters "start-time=2013-03-01T00:00:00Z")

1218

;; (parse-query-parameters "start-time=2013-03-01T00:00:00Z&end-time")

1219

;; (parse-query-parameters "start-time=2013-03-01T00:00:00Z&end-time=")

1220

;; (parse-query-parameters "start-time=2013-03-01T00:00:00Z&end-time=2013-03-01T00:00:01Z")

1221

;; (parse-query-parameters "start-time=2013-03-01T00:00:00Z&end-time&repository")

1222

;; (parse-query-parameters "start-time=2013-03-01T00:00:00Z&end-time=&repository=x/y")

1223

;; (parse-query-parameters "start-time=2013-03-01T00:00:00Z&end-time=2013-03-01T00:00:01Z&repository=x/y")

1224

1225

1226

(defun parse-header-configuration (header-property-list &optional (argument-list ()))

1227

(setf header-property-list (loop for (key value) on header-property-list by #'cddr

1228

                                    collect (remove-if-not #'alpha-char-p (string key))

1229

collect value))

1230

(setf argument-list (copy-list argument-list))

1231

(flet ((add-arg (key value)

1232

(when value (setf argument-list (list* key value argument-list))))

1233

(header (key)

1234

(loop for (name value) on header-property-list by #'cddr

1235

when (string-equal key name)

1236

do (return value)))

1237

(headers (key)

1238

(loop for (name value) on header-property-list by #'cddr

1239

when (string-equal key name)

1240

collect value)))

1241

(add-arg :accept-date-time (header "acceptDateTime"))

1242

(add-arg :agent-id (header "agentId"))

1243

(add-arg :agent-location (header "agentLocation"))

1244

(add-arg :api-key (header "apiKey"))

1245

(add-arg :base-iri (or (header "base") (header "baseIRI")))

1246

(add-arg :blank-node-prefix (header "skolemizePrefix"))

1247

(add-arg :blank-node-skolemize (header "skolemize"))

1248

(add-arg :default-context-term (header "defaultContextTerm"))

1249

(add-arg :default-graphs (or (header "defaultGraphs") (header "from") (headers "defaultGraphURI")))

1250

(add-arg :describe-form (header "describeForm"))

1251

(add-arg :describe-object-depth (header "describeObjectDepth"))

1252

(add-arg :describe-subject-depth (header "describeSubjectDepth"))

1253

(add-arg :dynamic-bindings (header "dynamicBindings"))

1254

(add-arg :federation-mode (header "federationMode"))

1255

(add-arg :end-time (header "endTime"))

1256

(add-arg :import-limit (header "importLimit"))

1257

(add-arg :memory-limit (header "memoryLimit"))

1258

(add-arg :named-contexts-term (header "namedContextsTerm"))

1259

(add-arg :named-graphs (or (header "namedGraphs") (header "fromNamed") (headers "namedGraphURI")))

1260

(add-arg :namespace-bindings (or (header "prefixes") (header "namespaceBindings")))

1261

(add-arg :operation-limit (header "operationLimit"))

1262

     (add-arg :provenance-repository-id (or (header "provenanceRepositoryID") (header "provenanceRepository")))

1263

(add-arg :provenance-record (header "provenanceRecord"))

1264

(add-arg :query-signature (or (header "signature") (header "querySignature")))

1265

(add-arg :repository-id (or (header "repositoryID") (header "repository")))

1266

     (add-arg :request-content-type (or (header "contentType") (header "queryContentType") (header "requestContentType")))

1267

     (add-arg :request-exchange (or (header "exchange") (header "requestExchange") (amqp:exchange-exchange (query-exchange))))

1268

(add-arg :request-routing-key (or (header "routingKey") (header "requestRoutingKey")))

1269

(add-arg :response-content-type (or (header "accept") (header "responseContentType")))

1270

(add-arg :response-limit (or (header "limit") (header "responseLimit") (header "queryLimit")))

1271

(add-arg :response-offset (or (header "offset") (header "responseOffset") (header "queryOffset")))

1272

(add-arg :revision-end-time (header "revisionEndTime"))

1273

(add-arg :revision-id (or (header "revisionUUID") (header "revisionID") (header "revision")))

1274

(add-arg :revision-start-time (header "revisionStartTime"))

1275

(add-arg :library-path (header "libraryPath"))

1276

(add-arg :start-time (header "startTime"))

1277

(add-arg :task-id (or (header "queryID") (header "id") (header "taskID")))

1278

(add-arg :time-interval (header "timeInterval"))

1279

(add-arg :time-limit (header "timeLimit"))

1280

(add-arg :toplevel-code (header "script"))

1281

(add-arg :trace-routing-key (header "traceRoutingKey"))

1282

(add-arg :undefined-variable-behavior (header "undefinedVariableBehavior"))

1283

(add-arg :user-id (or (header "userID") (header "userTag")))

1284

(add-arg :request-values (let ((args (or (headers "valuesData") (headers "values"))))

1285

(when args (mapcar #'parse-values-data args))))

1286

(add-arg :xslt-stylesheet (getarg "xsltStylesheet"))

1287

1288

(canonicalize-argument-list argument-list)))

1289

1290

1291

(defun parse-command-line-configuration (&optional (argument-list ()))

1292

;; start with whatever was given, add to it from the command line arguments

1293

(setf argument-list (copy-list argument-list))

1294

(flet ((add-arg (key value)

1295

(when value (setf argument-list (list* key value argument-list)))))

1296

(add-arg :accept-date-time (or (getarg "--accept-date-time") (getarg "--accept-datetime")))

1297

(add-arg :accounting-fd (getarg "--accounting-fd"))

1298

(add-arg :agent-id (getarg "--agent-id"))

1299

     (add-arg :agent-location (or (getarg "--agent-location") (getarg "--ip-address") (getarg "--request-ip-address")))

1300

(add-arg :api-key (getarg "--api-key"))

1301

(add-arg :base-iri (or (getarg "--base") (getarg "--base-iri")))

1302

(add-arg :blank-node-prefix (getarg "--skolize-prefix"))

1303

(add-arg :blank-node-skolemize (getarg "--skolemize"))

1304

(add-arg :default-context-term (getarg "--default-context-term"))

1305

(add-arg :default-graphs (or (getarg "--default-graphs") (getargs "--default-graph-uri")))

1306

(add-arg :describe-form (getarg "--describe-form"))

1307

(add-arg :describe-object-depth (getarg "--describe-object-depth"))

1308

(add-arg :describe-subject-depth (getarg "--describe-subject-depth"))

1309

(add-arg :dynamic-bindings (or (getarg "--dynamic-bindings") (getarg "--bindings")))

1310

(add-arg :tpf-bindings (or (getarg "--tpf-bindings")))

1311

(add-arg :end-time (getarg "--end-time"))

1312

(add-arg :federation-mode (getarg "--federation-mode"))

1313

(add-arg :import-limit (getarg "--import-limit"))

1314

(add-arg :library-path (or (getarg "--library-path") (getargs "--librarypath")))

1315

(add-arg :memory-limit (getarg "--memory-limit"))

1316

(add-arg :named-contexts-term (getarg "--named-contexts-term"))

1317

(add-arg :named-graphs (or (getarg "--named-graphs") (getargs "--named-graph-uri")))

1318

(add-arg :namespace-bindings (or (getarg "--prefixes") (getarg "--namespace-bindings")))

1319

(add-arg :operation-limit (getarg "--operation-limit"))

1320

     (add-arg :provenance-repository-id (or (getarg "--provenance-repository-id") (getarg "--provenance-repository")))

1321

(add-arg :provenance-record (getarg "--provenance-record"))

1322

(add-arg :query-signature (or (getarg "--signature") (getarg "--query-signature")))

1323

(add-arg :repository-id (or (getarg "--repository-id") (getarg "--repository")))

1324

     (add-arg :request-content-type (or (getarg "--content-type") (getarg "--query-content-type") (getarg "--request-content-type")))

1325

(add-arg :response-content-type (or (getarg "--accept") (getarg "--response-content-type")))

1326

(add-arg :response-limit (or (getarg "--limit") (getarg "--response-limit") (getarg "--query-limit")))

1327

     (add-arg :response-offset (or (getarg "--offset") (getarg "--response-offset") (getarg "--query-offset")))

1328

(add-arg :revision-end-time (getarg "--revision-end-time"))

1329

(add-arg :revision-id (or (getarg "--revision-uuid") (getarg "--revision-id") (getarg "--revision")))

1330

(add-arg :revision-start-time (getarg "--revision-start-time"))

1331

(add-arg :start-time (getarg "--start-time"))

1332

(add-arg :task-id (or (getarg "--id") (getarg "--task-id")))

1333

(add-arg :time-interval (getarg "--time-interval"))

1334

(add-arg :time-limit (getarg "--time-limit"))

1335

(add-arg :toplevel-code (getarg "--script"))

1336

(add-arg :undefined-variable-behavior (getarg "--undefined-variable-behavior"))

1337

(add-arg :user-id (or (getarg "--user-id") (getarg "--user-tag")))

1338

(add-arg :request-values (let ((arg (or (getarg "--values-data") (getarg "--values"))))

1339

(when arg (parse-values-data arg))))

1340

(add-arg :xslt-stylesheet (getarg "--xslt-stylesheet"))

1341

1342

(canonicalize-argument-list argument-list)))

1343

1344

;;; (parse-command-line-configuration)

1345

1346

1347

(defun call-with-configuration-bound (op &rest *request-configuration* &key

1348

                                          ((:agent-location *agent-location*) *agent-location*)

1349

                                          ((:agent-id *agent-id*) *agent-id*)

1350

((:agent *agent*) *agent*)

1351

((:api-key *api-key*) *api-key*)

1352

                                          ((:base-iri *base-iri*) *base-iri*)

1353

                                          ;; no json-ld context: the package does not yet exist

1354

                                          ((:dataset-graphs *dataset-graphs*) *dataset-graphs* dg-s)

1355

                                          ((:dataset-source *dataset-source*) (when dg-s :request *dataset-source*))

1356

                                          ((:describe-properties *describe-properties*) *describe-properties*)

1357

                                          ((:dynamic-bindings *dynamic-bindings*) *dynamic-bindings*)

1358

                                          ((:query-signature *query-signature*) *query-signature*)

1359

                                          ((:library-path *library-path*) *library-path*)

1360

                                          ((:repository-id *repository-id*) *repository-id*)

1361

                                          ((:task-id *task-id*) (or *task-id* (make-task-id)))

1362

((:user-id *user-id*) *user-id*)

1363

                                          ((:request-values *request-values*) *request-values*)

1364

                                          ((:request-properties *request-properties*) *request-properties*)

1365

                                          ((:request-content-type *request-content-type*) *request-content-type*)

1366

                                          ((:response-content-type *response-content-type*) *response-content-type*)

1367

                                          ((:response-limit *response-limit*) *response-limit*)

1368

                                          ((:response-offset *response-offset*) *response-offset*)

1369

                                          ((:revision-id *revision-id*) *revision-id*)

1370

                                          ((:xslt-stylesheet *xslt-stylesheet*)  *xslt-stylesheet*)

1371

&allow-other-keys)

1372

(apply #'call-with-metadata-bound op *metadata* *request-configuration*))

1373

1374

(defmacro with-configuration (overriding-arguments &body body)

1375

(let ((op (gensym)))

1376

`(flet ((,op () ,@body))

1377

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

1378

,(cond ((null overriding-arguments)

1379

`(call-with-configuration-bound #',op))

1380

((symbolp overriding-arguments)

1381

`(apply #'call-with-configuration-bound #',op ,overriding-arguments))

1382

((and (consp overriding-arguments) (oddp (length overriding-arguments)))

1383

`(apply #'call-with-configuration-bound #',op ,@overriding-arguments))

1384

((and (consp overriding-arguments) (evenp (length overriding-arguments)))

1385

`(call-with-configuration-bound #',op ,@overriding-arguments))

1386

(t

1387

(error "invalid with-configuration-bound argument: ~s." overriding-arguments))))))

1388

;;; (macroexpand '(with-configuration nil body))

1389

;;; (macroexpand '(with-configuration args body))

1390

;;; (macroexpand '(with-configuration (args) body))

1391

;;; (macroexpand '(with-configuration (:key value args) body))

1392

;;; (macroexpand '(with-configuration (:key value) body))

1393

1394

1395

(defun call-with-command-line-configuration-bound (op &rest args)

1396

   "Parse the configuration from arguments specified on the command line, extend/over-ride them with the given

1397

  call arguments, rebind the respective dynamic globals and the metadata cache to the combined result and

1398

invoke the given operator in that dynamic context."

1399

(declare (dynamic-extent args))

1400

(destructuring-bind (&rest parsed-args &key

1401

#+sbcl accounting-fd

1402

#+sbcl ((:accounting-destination *accounting-destination*)

1403

(if (typep accounting-fd '(integer 0))

1404

                                        (sb-sys::make-fd-stream accounting-fd :element-type 'character :output t)

1405

*accounting-destination*))

1406

&allow-other-keys)

1407

(parse-command-line-configuration args)

1408

(apply #'call-with-configuration-bound op parsed-args)))

1409

1410

(defmacro with-command-line-configuration (overriding-arguments &body body)

1411

(let ((op (gensym)))

1412

`(flet ((,op () ,@body))

1413

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

1414

,(cond ((null overriding-arguments)

1415

`(call-with-command-line-configuration-bound #',op))

1416

((symbolp overriding-arguments)

1417

`(apply #'call-with-command-line-configuration-bound #',op ,overriding-arguments))

1418

((and (consp overriding-arguments) (oddp (length overriding-arguments)))

1419

`(apply #'call-with-command-line-configuration-bound #',op ,@overriding-arguments))

1420

((and (consp overriding-arguments) (evenp (length overriding-arguments)))

1421

`(call-with-command-line-configuration-bound #',op ,@overriding-arguments))

1422

(t

1423

                (error "invalid with-command-line-configuration argument: ~s." overriding-arguments))))))

1424

1425

(defun load-command-line-configuration (&rest args)

1426

"extract and apply all settings from the command line."

1427

(load-configuration (loop for (key value) on (parse-command-line-configuration args) by #'cddr

1428

collect (list key value))))

1429

1430

1431

1432

(defun call-with-header-configuration-bound (op headers &rest args)

1433

"TO propare to process an AMQP request, parse the given headers,

1434

extend/over-ride those values with the given call arguments, rebind the

1435

respective dynamic globals and the metadata cache to the combined result

1436

and invoke the given operator in that dynamic context."

1437

(declare (dynamic-extent args))

1438

(let ((*request-headers* headers))

1439

(destructuring-bind (&rest parsed-args &key

1440

                                ((:request-routing-key *request-routing-key*) *request-routing-key*)

1441

                                ((:request-exchange *request-exchange*) *request-exchange*)

1442

((:operation *operation*) *operation*)

1443

&allow-other-keys)

1444

(parse-header-configuration headers args)

1445

(declare (dynamic-extent parsed-args))

1446

(apply #'call-with-configuration-bound op parsed-args))))

1447

1448

(defmacro with-header-configuration (headers-and-overriding-arguments &body body)

1449

(let ((op (gensym)))

1450

`(flet ((,op () ,@body))

1451

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

1452

,(cond ((symbolp headers-and-overriding-arguments)

1453

`(call-with-header-configuration-bound #',op ,headers-and-overriding-arguments))

1454

               ((and (consp headers-and-overriding-arguments) (evenp (length headers-and-overriding-arguments)))

1455

                `(apply #'call-with-header-configuration-bound #',op ,@headers-and-overriding-arguments))

1456

               ((and (consp headers-and-overriding-arguments) (oddp (length headers-and-overriding-arguments)))

1457

`(call-with-header-configuration-bound #',op ,@headers-and-overriding-arguments))

1458

(t

1459

                (error "invalid with-header-configuration argument: ~s." headers-and-overriding-arguments))))))

1460

;;; (macroexpand '(with-header-configuration nil body))

1461

;;; (macroexpand '(with-header-configuration headers body))

1462

;;; (macroexpand '(with-header-configuration (headers) body))

1463

;;; (macroexpand '(with-header-configuration (headers args) body))

1464

;;; (macroexpand '(with-header-configuration (headers :key value args) body))

1465

;;; (macroexpand '(with-header-configuration (headers :key value) body))

1466

1467

1468

1469

1470

;;;

1471

1472

(defgeneric configuration-setting-p (key)

1473

(:documentation "Given a key, determine whether it is a valid condiguration parameter based on

1474

whether a respective method is present in the setting operator. This approach short-cuts

1475

find method in the it tests the key specializer only.")

1476

(:method ((key symbol))

1477

(loop for method in (closer-mop:generic-function-methods #'(setf configuration-parameter))

1478

for specializer = (second (closer-mop:method-specializers method))

1479

when (and (typep specializer 'closer-mop:eql-specializer)

1480

(eql key (closer-mop:eql-specializer-object specializer)))

1481

do (return (values key method))))

1482

(:method ((key t))

1483

nil)

1484

(:method ((key string))

1485

     (configuration-setting-p (intern (string-upcase (substitute #\- #\_ key)) (load-time-value (find-package :keyword))))))

1486

1487

1488

(defgeneric find-property-symbol (term package)

1489

(:method ((term string) package)

1490

(flet ((canonicalize-property-name (name)

1491

(loop with capitalize = nil

1492

                    with buffer = (make-array (length name) :fill-pointer 0 :element-type 'character)

1493

for char across name

1494

do (case char

1495

((#\- #\_) (setf capitalize t))

1496

(t

1497

                          (vector-push (if (shiftf capitalize nil) (char-upcase char) (char-downcase char))

1498

buffer)))

1499

finally (return (subseq buffer 0 (length buffer))))))

1500

(or (find-symbol term package)

1501

(find-symbol (canonicalize-property-name term) package))))

1502

(:method ((term symbol) package)

1503

(find-property-symbol (symbol-name term) package)))

1504

1505

1506

(defun provenance-mode-value (value)

1507

(case value

1508

((|urn:dydra|:|internal| |urn:dydra|:|none|)

1509

value)

1510

(t

1511

(etypecase value

1512

(symbol (provenance-mode-value (string value)))

1513

(string

1514

(if (string-equal "urn:dydra:" value :end2 (min (length value) 10))

1515

(provenance-mode-value (intern-iri value))

1516

(or (rest (assoc value '(("external" . |urn:dydra|:|external|)

1517

("internal" . |urn:dydra|:|internal|)

1518

("none" . |urn:dydra|:|none|))

1519

:test #'string-equal))

1520

(error "Invalid provenance mode: ~s." value))))))))

1521

1522

(defgeneric load-configuration (source)

1523

(:documentation "Read and apply configuration specifications heuristically. That is,

1524

if the initial character is '(' read a list and interpret it as a setting or a

1525

set of settings. If the character is ':', treat it as a single setting.")

1526

1527

(:method :before ((source t))

1528

(setq *run-state* :configuration))

1529

1530

(:method ((source null))

1531

0)

1532

1533

(:method ((source string))

1534

(load-configuration (pathname source)))

1535

1536

(:method ((source pathname))

1537

(when (probe-file source)

1538

(let ((type (pathname-type source)))

1539

(cond ((string-equal type "lisp")

1540

(log-debug "load-configuration as lisp: ~s" source)

1541

(load source))

1542

((string-equal type "sxp")

1543

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

1544

(load-configuration stream)))

1545

(t

1546

(log-warn "load-configuration: anomalous source ~s" source))))))

1547

1548

(:method ((source stream))

1549

(log-debug "load-configuration: ~s" source)

1550

(let ((*package* (find-package :org.datagraph.spocq.implementation))

1551

(count 0)

1552

(*read-eval* (eq *agent* (system-agent))))

1553

(loop (case (peek-char t source nil nil)

1554

((#\: #\; #\()

1555

;; anything which indicates an impending s-expression

1556

(let ((entry (read source nil nil)))

1557

(etypecase entry

1558

(keyword

1559

(setf (configuration-parameter entry) (read source))

1560

(incf count))

1561

(null

1562

(return count))

1563

(cons

1564

(incf count (load-configuration entry))))))

1565

(t

1566

(return count))))))

1567

1568

(:method ((setting cons))

1569

(typecase (first setting)

1570

(cons (loop for (name value) in setting

1571

do (setf (configuration-parameter name) value)

1572

count name))

1573

(t (setf (configuration-parameter (first setting)) (second setting))

1574

1))))

1575

1576

(defun load-system-configuration (source)

1577

(prog1 (load-configuration source)

1578

(account *system-account-name*)))

1579

1580

1581

(defgeneric configuration-parameter (variable)

1582

(:documentation "Returns the current global binding for the parameter")

1583

(:method ((parameter symbol))

1584

(when (boundp parameter) (symbol-value parameter))))

1585

1586

1587

(defgeneric (setf configuration-parameter) (value variable)

1588

(:argument-precedence-order variable value)

1589

1590

(:method :before ((value t) (parameter t))

1591

(log-debug "(setf configuration-parameter): ~s: ~s" parameter value))

1592

(:method ((value t) (parameter t))

1593

(log-warn "Invalid configuration parameter: ~s: ~s" parameter value))

1594

1595

(:method ((value string) (name symbol))

1596

;; do not warn if it can be a request property, just save them in the property list

1597

;; (log-warn "Invalid configuration parameter: ~s: ~s" parameter value))

1598

(setf (getf *request-properties* (intern (string name) *variable-package*))

1599

(parse-term value)))

1600

1601

(:method ((value string) (parameter t))

1602

(let ((decoded-value (decode-configuration-parameter value parameter)))

1603

(if (stringp decoded-value)

1604

(call-next-method)

1605

(setf (configuration-parameter parameter) decoded-value))))

1606

1607

(:method ((value string) (parameter (eql :about)))

1608

;; in preparation for db-autonomy

1609

value)

1610

1611

(:method ((value string) (parameter (eql :accounting-exchange)))

1612

(setq *accounting-exchange* value))

1613

1614

(:method ((value string) (parameter (eql :accounting-queue)))

1615

(setq *accounting-queue* value))

1616

1617

(:method ((value symbol) (parameter (eql :accounting-destination)))

1618

(assert (accounting-destination-p value) ()

1619

"Invalid accounting destination: ~s." value)

1620

(setq *accounting-destination* value))

1621

1622

(:method ((value list) (parameter (eql :accounting-destination)))

1623

(assert (every #'accounting-destination-p value) ()

1624

"Invalid accounting destination: ~s." value)

1625

(setq *accounting-destination* value))

1626

1627

#+sbcl ; set it from a file-description

1628

(:method ((value integer) (parameter (eql :accounting-destination)))

1629

(setq *accounting-destination*

1630

(sb-sys::make-fd-stream value :element-type 'character :output t)))

1631

1632

(:method ((value string) (parameter (eql :agent-id)))

1633

(setq *agent-id* value))

1634

1635

(:method ((value string) (parameter (eql :agent-location)))

1636

(setq *agent-location* value))

1637

1638

(:method ((value integer) (parameter (eql :agp-maximum-threads)))

1639

(setq *agp-maximum-threads* value))

1640

1641

(:method ((value null) (parameter (eql :agp-maximum-threads)))

1642

(setq *agp-maximum-threads* value))

1643

1644

(:method ((value symbol) (parameter (eql :api-access-mode)))

1645

(assert (member value '(:read :read-write)))

1646

(setq *api-access-mode* value))

1647

1648

(:method ((value string) (parameter (eql :api-key)))

1649

(setf (api-key) value))

1650

1651

(:method ((value string) (parameter (eql :authentication-key)))

1652

(setf (api-key) value))

1653

1654

(:method ((value (eql 'delegated-agp)) (parameter (eql :agp-class)))

1655

(setq *class.agp* value))

1656

1657

(:method ((value (eql 'rdfcache-agp)) (parameter (eql :agp-class)))

1658

(setq *class.agp* value))

1659

1660

(:method ((value string) (parameter (eql :accounting-content-type)))

1661

(setq *accounting-content-type* (mime:mime-type value)))

1662

1663

(:method ((value t) (parameter (eql :authorize-service-access)))

1664

(setq *authorize-service-access* value))

1665

1666

(:method ((value t) (parameter (eql :base-iri)))

1667

(setf (base-iri) (intern-iri value)))

1668

1669

(:method ((value t) (parameter (eql |urn:dydra|:|baseIRI|)))

1670

(setf (configuration-parameter :base-iri) value))

1671

1672

(:method ((value t) (parameter (eql :blank-node-prefix)))

1673

(setf (blank-node-prefix) value))

1674

1675

(:method ((value string) (parameter (eql :blank-node-skolemize)))

1676

(setf (blank-node-skolemize) value))

1677

1678

(:method ((value symbol) (parameter (eql :blank-node-skolemize)))

1679

(setf (blank-node-skolemize) value))

1680

1681

(:method ((value string) (parameter (eql :broker-url)))

1682

;; the amqp uri is apuri

1683

(setq *broker-uri* (puri:uri value)))

1684

1685

(:method ((value puri:uri) (parameter (eql :broker-url)))

1686

;; the amqp uri is apuri

1687

(setq *broker-uri* value))

1688

1689

(:method ((value symbol) (parameter (eql :bgp-join-mode)))

1690

(assert (member value '(:match :scan)) ()

1691

"Invalid bgp-join-mode: ~s." value)

1692

(setq *bgp-join-mode* value))

1693

1694

(:method ((value string) (parameter (eql :collabortions)))

1695

;; in preparation for db-autonomy

1696

value)

1697

1698

(:method ((value t) (parameter (eql :configuration)))

1699

(load-configuration value))

1700

1701

(:method ((value list) (parameter (eql :context-terms)))

1702

(loop for (key . sub-value) in value

1703

do (ecase key

1704

((:default-context-term :named-contexts-term)

1705

(setf (configuration-parameter key) sub-value))))

1706

value)

1707

1708

(:method ((value symbol) (parameter (eql :default-context-term)))

1709

(assert (context-term-p value) ()

1710

"Invalid context term: ~s." value)

1711

(setf (default-context-term) value))

1712

1713

(:method ((value string) (parameter (eql :default-context-term)))

1714

(setf (default-context-term) (intern-iri value)))

1715

1716

(:method ((value t) (parameter (eql |urn:dydra|:|defaultContextTerm|)))

1717

(setf (configuration-parameter :default-context-term) value))

1718

1719

(:method ((values list) (parameter (eql :default-graphs)))

1720

(update-dataset-graphs (loop for value in values

1721

append (list :default-graph (intern-iri value)))

1722

:request))

1723

1724

(:method ((value string) (parameter (eql :default-graph-uri)))

1725

(update-dataset-graphs `(:default-graph ,(intern-iri value)) :request))

1726

1727

(:method ((value list) (parameter (eql :describe-settings)))

1728

(loop for (key . sub-value) in value

1729

do (ecase key

1730

((:describe-form :describe-object-depth describe-subject-depth)

1731

(setf (configuration-parameter key) sub-value))))

1732

value)

1733

1734

(:method ((value symbol) (parameter (eql :describe-form)))

1735

(assert (concise-bounded-description-describe-form-p value) ()

1736

"Invalid concise bounded description form: ~s: ~s" parameter value)

1737

(setf (describe-form) value))

1738

1739

(:method ((value string) (parameter (eql :describe-form)))

1740

(setf (describe-form) (intern-iri value)))

1741

1742

(:method ((value t) (parameter (eql |urn:dydra|:|describeForm|)))

1743

(setf (configuration-parameter :describe-form) value))

1744

1745

(:method ((value integer) (parameter (eql :describe-object-depth)))

1746

(setf (describe-object-depth) value))

1747

1748

(:method ((value null) (parameter (eql :describe-object-depth)))

1749

(setf (describe-object-depth) value))

1750

1751

(:method ((value string) (parameter (eql :describe-object-depth)))

1752

(setf (configuration-parameter :describe-object-depth)

1753

(or (ignore-errors (parse-integer value))

1754

(error "invalid describe-object-depth: ~s" value))))

1755

1756

(:method ((value t) (parameter (eql |urn:dydra|:|describeObjectDepth|)))

1757

(setf (configuration-parameter :describe-object-depth) value))

1758

1759

(:method ((value null) (parameter (eql :describe-properties)))

1760

(setq *describe-properties* value))

1761

(:method ((value cons) (parameter (eql :describe-properties)))

1762

(error "NYI: describe property sets are not supported."))

1763

(:method ((value (eql t)) (parameter (eql :describe-properties)))

1764

(setq *describe-properties* value))

1765

1766

(:method ((value integer) (parameter (eql :describe-subject-depth)))

1767

(setf (describe-subject-depth) value))

1768

1769

(:method ((value null) (parameter (eql :describe-subject-depth)))

1770

(setf (describe-subject-depth) value))

1771

1772

(:method ((value string) (parameter (eql :describe-subject-depth)))

1773

(setf (configuration-parameter :describe-subject-depth)

1774

(or (ignore-errors (parse-integer value))

1775

(error "invalid describe-subject-depth: ~s" value))))

1776

1777

(:method ((value t) (parameter (eql |urn:dydra|:|describeSubjectDepth|)))

1778

(setf (configuration-parameter :describe-subject-depth) value))

1779

1780

(:method ((value list) (parameter (eql :disabled-repositories)))

1781

(setq *disabled-repositories* value))

1782

1783

(:method ((value list) (parameter (eql :dynamic-bindings)))

1784

(setq *dynamic-bindings* (parse-dynamic-bindings value)))

1785

1786

(:method ((value string) (parameter (eql :engine-query-queue)))

1787

(setq *engine-query-queue* value))

1788

1789

(:method ((value string) (parameter (eql :engine-query-routing-key)))

1790

(setq *engine-query-routing-key* value))

1791

1792

(:method ((value string) (parameter (eql :engine-store-routing-key)))

1793

(setq *engine-store-routing-key* value))

1794

1795

(:method ((value string) (parameter (eql :engine-store-queue)))

1796

(setq *engine-store-queue* value))

1797

1798

(:method ((value t) (parameter (eql :error-destination)))

1799

(assert (error-destination-p value) ()

1800

"Invalid error destination: ~s." value)

1801

(setq *error-destination* value))

1802

1803

(:method ((value cons) (parameter (eql :error-destination)))

1804

(assert (every #'error-destination-p value) ()

1805

"Invalid error destination: ~s." value)

1806

(setq *error-destination* value))

1807

1808

(:method ((value integer) (parameter (eql :external-request-retry)))

1809

(assert (typep value '(integer 1)) ()

1810

(error "invalid external-request-retry value: ~s" value))

1811

(setq *external-request-retry* value))

1812

1813

(:method ((value integer) (parameter (eql :external-request-timeout)))

1814

(assert (typep value '(integer 0)) ()

1815

(error "invalid external-request-timeout value: ~s" value))

1816

(setq *external-request-timeout* value))

1817

1818

(:method ((value string) (parameter (eql :library-path)))

1819

(setf (library-path) (append (iri-sequence-value value) (library-path))))

1820

1821

(:method ((value cons) (parameter (eql :library-path)))

1822

(setf (library-path) (append value (library-path))))

1823

1824

(:method ((value null) (parameter (eql :library-path)))

1825

(setf (library-path) nil))

1826

1827

(:method ((value t) (parameter (eql |urn:dydra|:|libraryPath|)))

1828

(setf (configuration-parameter :library-path) value))

1829

1830

(:method ((value t) (parameter (eql :exit-on-errors)))

1831

(setq *exit-on-errors* value))

1832

1833

(:method ((value t) (parameter (eql :federation)))

1834

(setf (configuration-parameter :federation-mode) value))

1835

1836

(:method ((value symbol) (parameter (eql :federation-mode)))

1837

(assert (typep value 'federation-mode) ()

1838

"Invalid federation-mode: ~s." value)

1839

(setf (federation-mode) value))

1840

1841

(:method ((value string) (parameter (eql :federation-mode)))

1842

(setf (federation-mode) (or (find-symbol value "urn:dydra")

1843

                                   (error "Invalid federation-mode: ~s." value))))

1844

1845

(:method ((value null) (parameter (eql |urn:dydra|:|federationMode|)))

1846

(setf (configuration-parameter :federation-mode) value))

1847

1848

(:method ((value string) (parameter (eql :host-name)))

1849

(setq *host-name* value))

1850

1851

(:method ((value integer) (parameter (eql :import-limit)))

1852

(setf (import-limit) value))

1853

1854

(:method ((value pathname) (parameter (eql :load)))

1855

(with-compilation-unit () (load value)))

1856

1857

(:method ((value symbol) (parameter (eql :leftjoin-expansion-mode)))

1858

(assert (member value '(:combine :copy)) ()

1859

"Invalid join-expansion-mode: ~s." value)

1860

(setq *leftjoin-expansion-mode* value))

1861

1862

(:method ((value symbol) (parameter (eql :leftjoin-propagation-mode)))

1863

(assert (member value '(:propagate nil)) ()

1864

"Invalid join-propagation-mode: ~s." value)

1865

(setq *leftjoin-propagation-mode* value))

1866

1867

(:method ((value symbol) (parameter (eql :leftjoin-operator)))

1868

(assert (or (null value) (fboundp value)) ()

1869

"Invalid leftjoin-operator: ~s." value)

1870

(setq *leftjoin-operator* value))

1871

1872

(:method ((value list) (parameter (eql :localhost-authorities)))

1873

(assert (every #'stringp value) ()

1874

"Invalid localhost authorities: ~s." value)

1875

(setq *localhost-authorities* value))

1876

1877

(:method ((pathname string) (parameter (eql :log-pathname)))

1878

(setq *log-pathname* (pathname pathname)))

1879

1880

(:method ((value t) (parameter (eql :log-compilation-errors)))

1881

(setq *log-compilation-errors* value))

1882

1883

(:method ((value t) (parameter (eql :limit)))

1884

(setf (configuration-parameter :response-limit) value))

1885

1886

(:method ((value symbol) (parameter (eql :log-level)))

1887

(assert (member value *log-levels*) ()

1888

"Invalid log-level: ~s." value)

1889

(setq *log-level* value))

1890

1891

(:method ((value symbol) (parameter (eql :make-channel.class)))

1892

(assert (subtypep value 'channel) ()

1893

"Invalid channel class: ~s." value)

1894

(setq *make-channel.class* value))

1895

1896

(:method ((value number) (parameter (eql :match-rate)))

1897

(setq *match-rate* value))

1898

1899

(:method ((value list) (parameter (eql :materialized-repositories)))

1900

(assert (every #'parse-repository-id value) ()

1901

"Invalid materialized repository id list: ~s." value)

1902

(setq *materialized-repositories* value))

1903

1904

(:method ((value integer) (parameter (eql :memory-limit)))

1905

(setf (memory-limit) value))

1906

1907

(:method ((value t) (parameter (eql |urn:dydra|:|requestMemoryLimit|)))

1908

(setf (configuration-parameter :memory-limit) value))

1909

1910

(:method ((value metadata) (parameter (eql :metadata)))

1911

(setq *metadata* value))

1912

1913

(:method ((value string) (parameter (eql :mysql-database)))

1914

(setq *mysql-database* value))

1915

1916

(:method ((value string) (parameter (eql :mysql-host)))

1917

(setq *mysql-host* value))

1918

1919

(:method ((value null) (parameter (eql :mysql-host)))

1920

(setq *mysql-host* value))

1921

1922

(:method ((value symbol) (parameter (eql :named-contexts-term)))

1923

(assert (context-term-p value) ()

1924

"Invalid context term: ~s." value)

1925

(setf (named-contexts-term) value))

1926

1927

(:method ((value string) (parameter (eql :named-contexts-term)))

1928

(setf (named-contexts-term) (intern-iri value)))

1929

1930

(:method ((value t) (parameter (eql |urn:dydra|:|namedContextsTerm|)))

1931

(setf (configuration-parameter :named-context-term) value))

1932

1933

(:method ((values list) (parameter (eql :named-graphs)))

1934

(update-dataset-graphs (loop for value in values

1935

append (list :named-graph (intern-iri value)))

1936

:request))

1937

1938

(:method ((value string) (parameter (eql :named-graph-uri)))

1939

(update-dataset-graphs `(:named-graph ,(intern-iri value)) :request))

1940

1941

(:method ((value list) (parameter (eql :namespace-bindings)))

1942

(setf (configuration-parameter :prefixes) value))

1943

1944

(:method ((value string) (encoding (eql :namespace-bindings)))

1945

(setf (configuration-parameter :prefixes) value))

1946

1947

(:method ((value t) (parameter (eql :namespaces)))

1948

(setf (configuration-parameter :prefixes) value))

1949

1950

(:method ((value t) (parameter (eql :offset)))

1951

(setf (configuration-parameter :response-offset) value))

1952

1953

(:method ((value integer) (parameter (eql :operation-limit)))

1954

(setf (operation-limit) value))

1955

1956

(:method ((pathname string) (parameter (eql :pidfile-pathname)))

1957

;;;??? is this complete, or is it a directory?

1958

(setq *pidfile-pathname* (pathname pathname)))

1959

1960

(:method ((predicate-and-index cons) (parameter (eql :predicate-index)))

1961

(destructuring-bind (predicate index) predicate-and-index

1962

(assert (iri-p predicate) () "Invalid index predicate: ~s" predicate)

1963

(assert (iri-p index) () "Invalid index: ~s" index)

1964

(setf (gethash predicate *predicate-indices*) index)))

1965

1966

(:method ((value list) (parameter (eql :prefixes)))

1967

;; merge into the existing bindings (cf. :namespace-bindings)

1968

(setf (namespace-bindings)

1969

(remove-duplicates (append (loop for (prefix . iri) in value

1970

                                            collect (cons prefix (typecase iri

1971

                                                                   (cons (intern-iri (first iri)))

1972

                                                                   (t (intern-iri iri)))))

1973

(namespace-bindings))

1974

:test #'string-equal

1975

:from-end t

1976

:key #'first)))

1977

1978

(:method ((value pathname) (parameter (eql :prefixes)))

1979

(when (probe-file value)

1980

(setf (configuration-parameter :prefixes) (read-file value))))

1981

1982

(:method ((value string) (parameter (eql :prefixes)))

1983

;; use just the bindings ignoire any base iri

1984

(setf (configuration-parameter :prefixes) (decode-configuration-parameter value :prefixes)))

1985

1986

(:method ((value t) (parameter (eql |urn:dydra|:|prefixes|)))

1987

(setf (configuration-parameter :prefixes) value))

1988

1989

(:method ((value string) (parameter (eql :priority)))

1990

(setq *priority* value))

1991

1992

(:method ((value integer) (parameter (eql :privacy)))

1993

;; in preparation for db-autonomy

1994

value)

1995

1996

(:method ((value t) (parameter (eql :provenance-mode)))

1997

(setq *provenance-mode* (provenance-mode-value value)))

1998

1999

(:method ((value t) (parameter (eql :provenance-repository)))

2000

;; alias the parameter name to allow simpler settings file and ui

2001

(setf (configuration-parameter :provenance-repository-id) value))

2002

2003

(:method ((value null) (parameter (eql :provenance-repository-id)))

2004

(setf (provenance-repository-id) value))

2005

2006

(:method ((value string) (parameter (eql :provenance-repository-id)))

2007

(setf (provenance-repository-id) value))

2008

2009

(:method ((value t) (parameter (eql |urn:dydra|:|provenanceRepositoryId|)))

2010

(setf (configuration-parameter :provenance-repository-id) value))

2011

2012

(:method ((value list) (parameter (eql :quota)))

2013

(loop for (parameter value) on value by #'cddr

2014

do (ecase parameter

2015

((:seconds :time-limit)

2016

(setf (configuration-parameter :time-limit) value))

2017

((:bytes :memory-limit)

2018

(setf (configuration-parameter :memory-limit) value)))))

2019

2020

(:method ((value string) (parameter (eql :query-exchange)))

2021

(setq *query-exchange* value))

2022

2023

(:method ((value integer) (parameter (eql :query-maximum-length)))

2024

(setq *query-maximum-length* value))

2025

2026

(:method ((value integer) (parameter (eql :query-maximum-threads)))

2027

(setq *query-maximum-threads* value))

2028

2029

(:method ((value null) (parameter (eql :query-maximum-threads)))

2030

(setq *query-maximum-threads* value))

2031

2032

(:method ((value symbol) (parameter (eql :query-parser)))

2033

(assert (fboundp value) ()

2034

"Invalid query parser: ~s." value)

2035

(setq *query-parser* value))

2036

2037

(:method ((value string) (parameter (eql :query-parser-version)))

2038

(setq *query-parser* (find-symbol "Query-Parser" value))

2039

(assert (and *query-parser* (fboundp *query-parser*)) ()

2040

"Invalid query parser version: ~s." value))

2041

2042

(:method ((value symbol) (parameter (eql :query-parser-version)))

2043

(setf (configuration-parameter parameter) (string value)))

2044

2045

(:method ((value string) (parameter (eql :query-signature)))

2046

(setq *query-signature* value))

2047

(:method ((value null) (parameter (eql :query-signature)))

2048

(setq *query-signature* value))

2049

2050

(:method ((value string) (parameter (eql :rdfcache-executable-pathname)))

2051

(setf (configuration-parameter :rdfcache-executable-pathname) (pathname value)))

2052

2053

(:method ((value pathname) (parameter (eql :rdfcache-executable-pathname)))

2054

(unless (probe-file value)

2055

(error "invalid rdfcache-executable-pathname: ~s." value))

2056

(setq *executable-pathname.rdfcache* (pathname value)))

2057

2058

(:method ((value integer) (parameter (eql :rdf-string-length-maximum)))

2059

(setq *rdf-string-length-maximum* value))

2060

(:method ((value null) (parameter (eql :rdf-string-length-maximum)))

2061

(setq *rdf-string-length-maximum* value))

2062

2063

(:method ((value string) (parameter (eql :rdfcache-pathname)))

2064

(setq *rdfcache-pathname* (pathname value)))

2065

2066

(:method ((value pathname) (parameter (eql :rdfcache-pathname)))

2067

(setq *rdfcache-pathname* (pathname value)))

2068

2069

(:method ((value string) (parameter (eql :redis-host)))

2070

(setq *redis-host* (puri:uri value)))

2071

2072

(:method ((value string) (parameter (eql :redis-uri)))

2073

(setq *redis-host* (puri:uri value)))

2074

2075

;; the repository and revision class should change in sync

2076

(:method ((value (eql 'rdfcache-decimated-matrix-repository)) (parameter (eql :repository-class)))

2077

(setq *class.repository* value))

2078

2079

(:method ((value (eql 'rdfcache-consolidated-matrix-repository)) (parameter (eql :repository-class)))

2080

(setq *class.repository* value))

2081

2082

(:method ((value (eql 'rdfcache-stream-repository)) (parameter (eql :repository-class)))

2083

(setq *class.repository* value))

2084

2085

(:method ((value string) (parameter (eql :repository-id)))

2086

(setq *repository-id* value))

2087

2088

(:method ((value integer) (parameter (eql :repository-limit)))

2089

(setq *repository-limit* value))

2090

2091

(:method ((value integer) (parameter (eql :repository-time-to-live)))

2092

(setq *repository-time-to-live* value))

2093

2094

(:method ((value symbol) (parameter (eql :repository-resolution-mode)))

2095

(assert (typep value 'repository-resolution-mode) ()

2096

"Invalid repository-resolution-mode: ~s." value)

2097

(setq *repository-resolution-mode* value))

2098

2099

(:method ((value string) (parameter (eql :request-content-type)))

2100

(setq *request-content-type* (mime:mime-type value)))

2101

(:method ((value mime:mime-type) (parameter (eql :request-content-type)))

2102

(setq *request-content-type* value))

2103

2104

(:method ((data null) (option (eql :request-values)))

2105

(setq *request-values* ()))

2106

2107

(:method ((data cons) (option (eql :request-values)))

2108

;; add the values to those already present

2109

(loop for (variables . solutions) in data

2110

if (and (listp variables) (every #'variable-p variables))

2111

collect (multiple-value-bind (dimensions ordered-solutions)

2112

(alphabetize-bindings variables solutions)

2113

(let ((binding (cons dimensions ordered-solutions)))

2114

(push binding *request-values*)

2115

binding))

2116

else do (error "invalid values data: ~s" data)))

2117

2118

(:method ((data string) (option (eql :request-values)))

2119

(setf (configuration-parameter :request-values) (list (parse-values-data data))))

2120

2121

(:method ((value string) (parameter (eql :resource-api-endpoint)))

2122

(or (typep (puri:uri value) 'puri:uri)

2123

(error "invalid resource-api-endpoint value: ~s" value))

2124

(pushnew value *resource-api-endpoints* :test #'equal))

2125

(:method ((value null) (parameter (eql :resource-api-endpoint)))

2126

(setq *resource-api-endpoints* nil))

2127

2128

(:method ((value string) (parameter (eql :response-content-type)))

2129

(setq *response-content-type* (mime:mime-type value)))

2130

(:method ((value mime:mime-type) (parameter (eql :response-content-type)))

2131

(setq *response-content-type* value))

2132

2133

(:method ((value list) (parameter (eql :response-header-types)))

2134

(assert (every #'keywordp value) ()

2135

"Invalid response-header-types: ~s." value)

2136

(setq *response-header-types* value))

2137

2138

(:method ((value integer) (parameter (eql :response-limit)))

2139

(setf (response-limit) value))

2140

(:method ((value null) (parameter (eql :response-limit)))

2141

(setf (response-limit) value))

2142

(:method ((value string) (parameter (eql :response-limit)))

2143

(setf (configuration-parameter :response-limit)

2144

(or (ignore-errors (parse-integer value))

2145

(error "invalid response-limit: ~s" value))))

2146

2147

(:method ((value integer) (parameter (eql :response-offset)))

2148

(setf (response-offset) value))

2149

(:method ((value null) (parameter (eql :response-offset)))

2150

(setf (response-offset) value))

2151

(:method ((value string) (parameter (eql :response-offset)))

2152

(setf (configuration-parameter :response-offset)

2153

(or (ignore-errors (parse-integer value))

2154

(error "invalid response-offset: ~s" value))))

2155

2156

(:method ((value string) (parameter (eql :revision-id)))

2157

(setq *revision-id* value))

2158

2159

(:method ((value symbol) (parameter (eql :runtime-function)))

2160

(assert (fboundp value) ()

2161

"Invalid runtime function: ~s." value)

2162

(setq *runtime-function* value))

2163

2164

(:method ((value string) (parameter (eql :server-host-name)))

2165

(setq *server-host-name* value))

2166

2167

(:method ((value integer) (parameter (eql :service-request-count-limit)))

2168

(setq *service-request-count-limit* value))

2169

2170

(:method ((value null) (parameter (eql :service-request-count-limit)))

2171

(setq *service-request-count-limit* value))

2172

2173

(:method ((value integer) (parameter (eql :scan-rate)))

2174

(setq *scan-rate* value))

2175

2176

   #+(or) ;; must be a command-line parameter in order to be used to open syslog before loading the configuration

2177

(:method ((value string) (parameter (eql :service-name)))

2178

(setq *service-name* value))

2179

2180

(:method ((value string) (parameter (eql :site-name)))

2181

(setq *site-name* value))

2182

2183

(:method ((value string) (parameter (eql :site-protocol)))

2184

(setq *site-protocol* value))

2185

2186

(:method ((value t) (parameter (eql :skolemize-prefix)))

2187

(setf (blank-node-prefix) value))

2188

2189

(:method ((value t) (parameter (eql :skolemize)))

2190

(setf (blank-node-skolemize) value))

2191

2192

(:method ((value t) (parameter (eql |urn:dydra|:|skolemize|)))

2193

(setf (configuration-parameter :skolemize) value))

2194

2195

(:method ((value integer) (parameter (eql :solution-limit)))

2196

(setf (solution-limit) value)

2197

(setf *solution-count-limit* value))

2198

2199

(:method ((value t) (parameter (eql |urn:dydra|:|requestSolutionLimit|)))

2200

(setf (configuration-parameter :solution-limit) value))

2201

2202

(:method ((value string) (parameter (eql :store-store-queue)))

2203

(setq *store-store-queue* value))

2204

2205

(:method ((value t) (parameter (eql :store-system-events)))

2206

(setq *store-system-events* value))

2207

2208

(:method ((value string) (parameter (eql :store-exchange)))

2209

(setq *store-exchange* value))

2210

2211

(:method ((value string) (parameter (eql :store-content-type)))

2212

(setq *store-content-type* (mime:mime-type value)))

2213

2214

(:method ((value string) (parameter (eql :store-store-routing-key)))

2215

(setq *store-store-routing-key* value))

2216

2217

(:method ((value t) (parameter (eql :strict-vocabulary-terms)))

2218

(setf (strict-vocabulary-terms) value))

2219

2220

(:method ((value t) (parameter (eql :strict-aggregation-sample)))

2221

(assert (typep value 'boolean) ()

2222

"Invalid strict-aggregation-sample behaviour: ~s." value)

2223

(setq *strict-aggregation-sample* value))

2224

2225

(:method ((value t) (parameter (eql |urn:dydra|:|strictVocabularyTerms|)))

2226

(setf (configuration-parameter :strict-vocabulary-terms) value))

2227

2228

(:method ((value string) (parameter (eql :store-uri)))

2229

(setq *store-uri* value))

2230

2231

(:method ((value string) (parameter (eql :system-api-key)))

2232

(when *system-api-key*

2233

(error "Not permitted to reconfigure the system api-key."))

2234

(setq *system-api-key* value))

2235

2236

(:method ((value string) (parameter (eql :task-id)))

2237

(setq *task-id* value))

2238

2239

(:method ((value null) (parameter (eql :task-id)))

2240

(setq *task-id* value))

2241

2242

(:method ((value integer) (parameter (eql :time-limit)))

2243

(setf (time-limit) value))

2244

2245

(:method ((value t) (parameter (eql |urn:dydra|:|requestTimeLimit|)))

2246

(setf (configuration-parameter :time-limit) value))

2247

2248

(:method ((value integer) (parameter (eql :thread-count-limit)))

2249

(setq *thread-count-limit* value))

2250

2251

(:method ((value null) (parameter (eql :thread-count-limit)))

2252

(setq *thread-count-limit* value))

2253

2254

(:method ((value string) (parameter (eql :thread-name)))

2255

(setq *thread-name* value))

2256

2257

(:method ((value null) (parameter (eql :thread-name)))

2258

(setq *thread-name* value))

2259

2260

(:method ((value cons) (parameter (eql :thread-specifications)))

2261

(setq *thread-specifications* value))

2262

2263

(:method ((value symbol) (parameter (eql :toplevel-function)))

2264

(setq *toplevel-function* (symbol-function value)))

2265

2266

(:method ((value symbol) (parameter (eql :undefined-variable-behavior)))

2267

(assert (undefined-variable-behavior-p value) ()

2268

"Invalid undefined variable behaviour: ~s." value)

2269

(setf (undefined-variable-behavior) value))

2270

2271

(:method ((value string) (parameter (eql :undefined-variable-behavior)))

2272

(setf (undefined-variable-behavior) (intern-iri value)))

2273

2274

(:method ((value t) (parameter (eql |urn:dydra|:|undefinedVariableBehavior|)))

2275

(setf (configuration-parameter :undefined-variable-behavior) value))

2276

2277

(:method ((value string) (parameter (eql :user-id)))

2278

(setq *user-id* value))

2279

2280

(:method ((value null) (parameter (eql :user-id)))

2281

(setq *user-id* value))

2282

2283

(:method (data (option (eql :values)))

2284

(setf (configuration-parameter :request-values) data)))

2285

2286

2287

;; (parse-sparql "base <http://test> prefix xxx: \"http://asdf\" select * where {}")

2288

2289

(defun request-argument (name)

2290

"Iff an argument was present in the request configuration - that is the request headers or their

2291

equivalent command-line argument, then return that value. Checked when setting query pragmas

2292

to permit the request argument to over-ride that in the query text."

2293

(etypecase (first *request-configuration*)

2294

(cons (rest (assoc name *request-configuration*)))

2295

(null nil)

2296

(symbol (getf *request-configuration* name))))

2297

2298

(defun set-pragma (name value)

2299

"Set a parser processing pragma, given the NAME and VALUE

2300

NAME : string : process know settings. unknown settings are logged, but ignored.

2301

  VALUE : string : a uri reference lexical form to be interpreted specific to each configuration parameter.

2302

VALUES : true iff processed"

2303

2304

(assert-argument-types set-pragma (name string) (value string))

2305

(log-debug "set-pragma: (~s ~s)" name value)

2306

(flet ((uri-pragma-value (value)

2307

(flet ((prefixed-substring (prefix)

2308

                     (when (string-equal prefix value :end2 (min (length value) (length prefix)))

2309

(subseq value (length prefix)))))

2310

(or (prefixed-substring "data:,")

2311

(prefixed-substring (iri-lexical-form (base-iri))))))

2312

(list-node-integer (lexical-form)

2313

(let ((prefix (package-name (symbol-package '|rdf|:|rest|))))

2314

              (assert (string-equal prefix lexical-form :end2 (min (length prefix) (length lexical-form))) ()

2315

"Invalid count: ~s." lexical-form)

2316

(parse-integer value :start (1+ (length prefix))))))

2317

(setf name (remove-if-not #'alpha-char-p name))

2318

(when (and (> (length name) 6) (string-equal "pragma" name :end2 6))

2319

(setf name (subseq name 6)))

2320

(cond ((string-equal name "APIKEY") ;; "data:,the-key"

2321

(unless (request-argument :api-key)

2322

(let ((key (uri-pragma-value value)))

2323

(if key

2324

(setf (api-key) key)

2325

(error "Invalid API key: ~s." value)))))

2326

2327

((string-equal name "BASE")

2328

(unless (request-argument :base)

2329

(setf (base-iri) (intern-iri (uri-pragma-value value)))))

2330

2331

((or (string-equal name "blankNodePrefix") (string-equal name "skolemizePrefix"))

2332

(unless (request-argument :blank-node-prefix)

2333

(setf (blank-node-prefix) (uri-pragma-value value))))

2334

2335

((or (string-equal name "blankNodeSkolemize") (string-equal name "skolemize"))

2336

(unless (request-argument :blank-node-skolemize)

2337

(setf (blank-node-skolemize) (uri-pragma-value value))

2338

              (when (member (blank-node-skolemize) '(|urn:dydra|:|skolemize| |urn:dydra|:|skolemize-export|))

2339

(unless (blank-node-prefix)

2340

(setf (blank-node-prefix) (compute-blank-node-global-label))))))

2341

2342

((string-equal name "defaultContextTerm")

2343

(unless (request-argument :default-context-term)

2344

(setf (default-context-term) (intern-iri value))))

2345

2346

((string-equal name "describeForm")

2347

(unless (request-argument :describe-form)

2348

(setf (describe-form) (intern-iri value))))

2349

2350

((string-equal name "describeObjectDepth")

2351

(unless (request-argument :describe-object-depth)

2352

(setf (describe-object-depth) (list-node-integer value))))

2353

2354

((string-equal name "describeSubjectDepth")

2355

(unless (request-argument :describe-subject-depth)

2356

(setf (describe-subject-depth) (list-node-integer value))))

2357

2358

((or (string-equal name "federation") (string-equal name "federationMode"))

2359

(unless (request-argument :federation-mode)

2360

(setf (federation-mode) (federation-mode-value value))))

2361

2362

((string-equal name "memoryLimit")

2363

(unless (request-argument :memory-limit)

2364

(setf (memory-limit) (list-node-integer value))))

2365

2366

((string-equal name "namedContextsTerm")

2367

(unless (request-argument :named-contexts-term)

2368

(setf (named-contexts-term) (intern-iri value))))

2369

2370

((string-equal name "operationLimit")

2371

(unless (request-argument :operation-limit)

2372

(setf (operation-limit) (list-node-integer value))))

2373

#+(or)

2374

((or (string-equal name "provenanceRepositoryId")

2375

(string-equal name "provenanceRepository"))

2376

(unless (request-argument :provenance-repository-id)

2377

(setf (provenance-repository-id) value)))

2378

2379

((string-equal name "responseLimit")

2380

(unless (request-argument :response-limit)

2381

(setf (response-limit) (list-node-integer value))))

2382

2383

((string-equal name "response-offset")

2384

(unless (request-argument :response-offset)

2385

(setf (response-offset) (list-node-integer value))))

2386

2387

((string-equal name "libraryPath")

2388

(unless (request-argument :library-path)

2389

;; through configuration-parameter to perform parsing

2390

(setf (configuration-parameter :library-path) value)))

2391

2392

((string-equal name "timeLimit")

2393

(unless (request-argument :time-limit)

2394

(setf (time-limit) (list-node-integer value))))

2395

2396

((string-equal name "undefinedVariableBehavior")

2397

(unless (request-argument :undefined-variable-behavior)

2398

(setf (undefined-variable-behavior) (intern-iri value))))

2399

2400

(t

2401

(when (plusp (length name))

2402

(let ((pragma-key (find-symbol name "urn:dydra")))

2403

(if pragma-key

2404

(setf (pragma-value pragma-key) value)

2405

;; ignore unknown pragmas as they are prefix bindings

2406

(return-from set-pragma nil))))))))

2407

2408

(defparameter *warn-on-invalid-pragma* t)

2409

2410

(defgeneric (setf pragma-value) (value key)

2411

(:method ((value string) (key (eql '|urn:dydra|:|describeProperties|)))

2412

(unless (request-argument :describe-properties)

2413

(setf (configuration-parameter :describe-properties)

2414

(cond ((search "true" value :test #'char-equal) t)

2415

((search "false" value :test #'char-equal) nil)

2416

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

2417

(:method ((value string) (key (eql '|urn:dydra|:|provenanceRepositoryId|)))

2418

;; use just the last two parts

2419

(unless (request-argument :provenance-repository-id)

2420

(let ((id (last (split-string value "/") 2)))

2421

(if (= (length id) 2)

2422

(setf (provenance-repository-id) (make-repository-id :account-name (first id)

2423

                                                                :repository-name (second id)))

2424

(call-next-method)))))

2425

(:method (value key)

2426

(when *warn-on-invalid-pragma*

2427

(log-warn "invalid pragma: ~s ~s" key value))

2428

nil))

2429

2430

2431

2432

;;;

2433

2434

(defun validate-configuration ()

2435

"Examine the current configuration.

2436

Ensure that a task id is present.

2437

Ensure that the agent is specified, wither by id or by key.

2438

If anything is not permitted, signal an error."

2439

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

2440

(error 'spocq.e:runtime-error

2441

:query nil

2442

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

2443

#+(or) ;; this precludes anonymous users

2444

(cond ((eq *agent* (system-agent)))

2445

(*agent-id*)

2446

((api-key))

2447

(t

2448

(error "validate-configuration: Neither agent id nor API key is present")))

2449

(unless *task-id*

2450

(setq *task-id* (make-v1-uuid-string))))

2451

2452

2453

(defun validate-repository-configuration (id configuration &key (if-does-not-exist :error))

2454

(let ((invalid-keys (set-difference (mapcar #'first configuration) *configuration-keys*)))

2455

(cond ((null invalid-keys)

2456

(with-instance-metadata ((repository id))

2457

(load-configuration configuration)))

2458

(t

2459

(ecase if-does-not-exist

2460

(:error (error "Invalid configuration keys ~s. Permitted are ~s."

2461

                             invalid-keys (set-difference *configuration-keys* (mapcar #'first configuration))))

2462

((nil) nil))))))

2463

2464

(defun validate-account-configuration (id configuration &key (if-does-not-exist :error))

2465

(let ((invalid-keys (set-difference (mapcar #'first configuration) *configuration-keys*)))

2466

(cond ((null invalid-keys)

2467

(with-instance-metadata ((account id))

2468

(load-configuration configuration)))

2469

(t

2470

(ecase if-does-not-exist

2471

(:error (error "Invalid configuration keys ~s. Permitted are ~s."

2472

                             invalid-keys (set-difference *configuration-keys* (mapcar #'first configuration))))

2473

((nil) nil))))))

2474

2475

2476

2477

2478

;;;

2479

;;; encoding-specific support for reading configurations

2480

2481

(defgeneric encode-prefix-parameter (content parameter)

2482

(:method ((content list) (parameter (eql |urn:dydra|:|prefixes|)))

2483

(with-output-to-string (stream)

2484

(loop for (prefix . namesace-name) in content

2485

do (format stream "PREFIX ~a: <~a>~%" prefix namesace-name))))

2486

2487

(:method ((content t) (parameter t))

2488

content))

2489

2490

;;; (defparameter *prefix-prolog-pattern* (cl-ppcre:create-scanner ".*PREFIX ([^:]+): <([^>]+)>"))

2491

(defparameter *prefix-prolog-pattern*

2492

(cl-ppcre:create-scanner ;; "\\s*(?:PREFIX\\s+)?([a-zA-Z_][^:]+)?:\\s+<([^>]*)>"

2493

'(:SEQUENCE (:GREEDY-REPETITION 0 NIL (:alternation :WHITESPACE-CHAR-CLASS

2494

                                                        (:sequence #\\ #\n)))

2495

(:alternation

2496

(:sequence (:register (:alternation "@prefix" "PREFIX"))

2497

(:GREEDY-REPETITION 1 NIL :WHITESPACE-CHAR-CLASS)

2498

(:GREEDY-REPETITION 0 1

2499

(:REGISTER

2500

                                                 (:SEQUENCE (:CHAR-CLASS (:RANGE #\a #\z) (:RANGE #\A #\Z) #\_)

2501

                                                            (:GREEDY-REPETITION 0 NIL (:INVERTED-CHAR-CLASS #\: :WHITESPACE-CHAR-CLASS)))))

2502

(:GREEDY-REPETITION 0 NIL :WHITESPACE-CHAR-CLASS)

2503

#\: (:GREEDY-REPETITION 0 NIL :WHITESPACE-CHAR-CLASS) #\<

2504

                            (:REGISTER (:GREEDY-REPETITION 0 NIL (:INVERTED-CHAR-CLASS #\>))) #\>)

2505

(:sequence (:register (:alternation "@base" "BASE"))

2506

(:GREEDY-REPETITION 1 NIL :WHITESPACE-CHAR-CLASS) #\<

2507

                            (:REGISTER (:GREEDY-REPETITION 0 NIL (:INVERTED-CHAR-CLASS #\>))) #\>)))

2508

:case-insensitive-mode t))

2509

2510

(defparameter *prefix-tsv-pattern*

2511

(cl-ppcre:create-scanner

2512

'(:SEQUENCE (:sequence (:REGISTER

2513

                            (:SEQUENCE (:CHAR-CLASS (:RANGE #\a #\z) (:RANGE #\A #\Z) #\_)

2514

                                       (:GREEDY-REPETITION 0 NIL (:INVERTED-CHAR-CLASS #\: :WHITESPACE-CHAR-CLASS)))))

2515

#\tab

2516

(:REGISTER (:GREEDY-REPETITION 1 NIL :everything)))

2517

:case-insensitive-mode t))

2518

2519

;;; (cl-ppcre:scan-to-strings *prefix-prolog-pattern* "PREFIX : <http://>")

2520

;;; (cl-ppcre:scan-to-strings *prefix-prolog-pattern* "PREFIX cc: <http://creativecommons.org/ns#>")

2521

;;; (cl-ppcre:scan-to-strings *prefix-prolog-pattern* "prefix cc: <http://creativecommons.org/ns#>")

2522

;;; (cl-ppcre:scan-to-strings *prefix-prolog-pattern* "\\n cc: <http://creativecommons.org/ns#>")

2523

2524

(defun parse-prefix-bindings (content)

2525

(typecase content

2526

(string

2527

(setf content (trim-string-whitespace content))

2528

(if (member content '("" "NULL") :test #'string-equal)

2529

()

2530

(case (char content 0)

2531

(#\( (let ((*package* (find-package :spocq.i))

2532

(*read-eval* nil))

2533

(read-from-string content)))

2534

            ;(#\{ (parse-json content))

2535

(t

2536

(let ((bindings ())

2537

(base nil))

2538

(loop for line in (split-string content #(#\return #\linefeed))

2539

when (plusp (length line))

2540

do (multiple-value-bind (result registers)

2541

                                         (cl-ppcre:scan-to-strings *prefix-prolog-pattern* line)

2542

;;;(print registers)

2543

(if result

2544

(cond ((aref registers 3)

2545

(setf base (intern-iri (aref registers 4))))

2546

(t

2547

(push (cons (or (aref registers 1) "")

2548

                                             (intern-iri (aref registers 2)))

2549

bindings)))

2550

(multiple-value-bind (result registers)

2551

                                               (cl-ppcre:scan-to-strings *prefix-tsv-pattern* line)

2552

(when result

2553

                              (push (cons (aref registers 0) (intern-iri (aref registers 1)))

2554

bindings))))))

2555

(values (reverse bindings)

2556

base))))))))

2557

#|

2558

(equalp (parse-prefix-bindings "prefix cc: <http://creativecommons.org/ns1#>

2559

\\n cc: <http://creativecommons.org/ns2#>")

2560

2561

|#

2562

2563

(defgeneric decode-configuration-parameter (source encoding)

2564

(:method ((content t) (encoding t))

2565

;; if none is known, return the value

2566

content)

2567

2568

(:method :around ((content string) (encoding t))

2569

(call-next-method (string-trim #(#\space #\tab #\return #\linefeed) content) encoding))

2570

2571

(:method ((content string) (encoding t))

2572

(when (plusp (length content))

2573

(let ((*read-eval* nil))

2574

(read-from-string content))))

2575

;; some specific values are left as strings

2576

(:method ((content string) (encoding (eql '|urn:dydra|:|location|)))

2577

(string-trim #(#\space #\linefeed #\return) content))

2578

(:method ((content string) (encoding (eql :location)))

2579

(decode-configuration-parameter content '|urn:dydra|:|location|))

2580

(:method ((content string) (encoding (eql :prefixes)))

2581

     "given a prefix prologue, parse it as per s-exp, json or sparql syntax (with a regex) and construct the binding a-list."

2582

(setf content (trim-string-whitespace content))

2583

(when (plusp (length content))

2584

(case (char content 0)

2585

(#\( (let ((*package* (find-package :spocq.i))

2586

(*read-eval* nil))

2587

(read-from-string content)))

2588

(#\{ (parse-json content))

2589

(t

2590

(parse-prefix-bindings content)))))

2591

2592

(:method ((content string) (encoding (eql :namespace-bindings)))

2593

(decode-configuration-parameter content :prefixes))

2594

2595

(:method ((content string) (parameter (eql |urn:dydra|:|prefixes|)))

2596

(decode-configuration-parameter content :prefixes))

2597

2598

(:method ((content string) (encoding (eql :describe-settings)))

2599

(ecase (char content 0)

2600

(#\(

2601

(let ((*package* (find-package :spocq.i))

2602

(*read-eval* nil))

2603

(read-from-string content)))

2604

(#\{

2605

(loop for (key . value) in (parse-json content)

2606

collect (cons (intern (string-upcase key) :keyword) value)))))

2607

2608

(:method ((content string) (encoding (eql :context-terms)))

2609

(ecase (char content 0)

2610

(#\(

2611

(let ((*package* (find-package :spocq.i))

2612

(*read-eval* nil))

2613

(read-from-string content)))

2614

(#\{

2615

(loop for (key . value) in (parse-json content)

2616

collect (cons (intern (string-upcase key) :keyword) value)))))

2617

2618

(:method ((content string) (encoding (eql |urn:dydra|:|skolemize|)))

2619

(cond ((string-equal content "export") |urn:dydra|:|skolemize-export|)

2620

((string-equal content "import") |urn:dydra|:|skolemize-insert|)

2621

((string-equal content "skolemize") |urn:dydra|:|skolemize|)

2622

((string-equal content "nil") nil)

2623

((find-property-symbol content "urn:dydra"))

2624

(t

2625

(error "invalid skolemization mode: ~s" content))))

2626

2627

(:method ((content string) (encoding (eql |urn:dydra|:|defaultContextTerm|)))

2628

(or (find-property-symbol content "urn:dydra")

2629

(error "invalid default context term: ~s" content)))

2630

2631

(:method ((content string) (encoding (eql |urn:dydra|:|namedContextsTerm|)))

2632

(or (find-property-symbol content "urn:dydra")

2633

(error "invalid named contexts term: ~s" content)))

2634

2635

(:method ((content string) (encoding (eql |urn:dydra|:|provenanceRepositoryId|)))

2636

(if (eql (char content 0) #\")

2637

(subseq content 1 (1- (length content)))

2638

content))

2639

2640

(:method ((content string) (encoding (eql |urn:dydra|:|undefinedVariableBehavior|)))

2641

(cond ((string-equal content "dynamic") |urn:dydra|:|dynamicBinding|)

2642

((find-property-symbol content "urn:dydra"))

2643

(t

2644

(error "invalid undefined variable behavior: ~s" content)))))

2645

;;; (spocq.i::decode-configuration-parameter "PREFIX : <http://>" :prefix)

2646

;;; (spocq.i::decode-configuration-parameter "PREFIX cc: <http://creativecommons.org/ns#>" :prefix)

2647

#+(or)

2648

(let ((bindings ()))

2649

(cl-ppcre:do-register-groups (prefix namespace-name) (*prefix-prolog-pattern*

2650

                                                                "PREFIX cc: <http://creativecommons.org/ns#>

2651

                                                                 prefix xsd: <http://www.w3.org/2001/XMLSchema#>

2652

                                                                  rdf: <http://www.w3.org/1999/02/22-rdf-syntax-ns#>"

2653

                                                                nil :sharedp nil)

2654

(push (cons (or prefix "") (intern-iri namespace-name)) bindings))

2655

(reverse bindings))

2656

2657

2658

#+(or)

2659

(loop for pathname in (directory "/srv/dydra/accounts/*/prefixes")

2660

       collect (list pathname (decode-configuration-parameter (read-file pathname) (intern (string-upcase (pathname-name pathname)) :keyword))))

2661

2662

;;;

2663

;;; resolve accept mime type

2664

2665

(defparameter *accept-specification-scanner*

2666

(cl-ppcre:create-scanner '(:sequence

2667

                              (:register (:sequence (:greedy-repetition 1 nil (:char-class (:range #\A #\Z) (:range #\a #\z) #\*))

2668

#\/

2669

                                                    (:greedy-repetition 1 nil (:char-class :word-char-class #\+ #\- #\*))))

2670

                              (:GREEDY-REPETITION 0 1 (:sequence #\; #\q #\= (:register (:sequence (:greedy-repetition 1 nil (:char-class (:range #\0 #\9)))

2671

#\.

2672

                                                                                                   (:greedy-repetition 1 nil (:char-class (:range #\0 #\9)))))))

2673

(:GREEDY-REPETITION 0 1 #\,))))

2674

(defun parse-accept-specification (accept-string)

2675

(let ((accept-list ()))

2676

(cl-ppcre:do-scans (binding-start bindings-end starts ends *accept-specification-scanner* accept-string)

2677

                        (push (cons (subseq accept-string (aref starts 0) (aref ends 0))

2678

                                    (if (and (aref starts 1) (> (aref ends 1) (aref starts 1)))

2679

                                      (meta:parse-float (subseq accept-string (aref starts 1) (aref ends 1)))

2680

1.0))

2681

accept-list))

2682

(sort accept-list #'> :key #'rest)))

2683

 ;;; (cl-ppcre:scan-to-strings *accept-specification-scanner* "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8,application/rdf+xml;q=0.93,text/rdf+n3;q=0.5")

2684

 ;;; (parse-accept-specification "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8,application/rdf+xml;q=0.93,text/rdf+n3;q=0.5")

2685

2686

(defgeneric select-mime-type (accept-specification mime-types)

2687

(:method ((accept-specification null) (mime-types list))

2688

(first mime-types))

2689

(:method ((accept-string string) mime-types)

2690

(select-mime-type (mapcar #'first (parse-accept-specification accept-string)) mime-types))

2691

(:method ((accept-list list) (mime-types list))

2692

(loop for accept-mime-type-string in accept-list

2693

for accept-mime-type = (cond ((ignore-errors (mime-type accept-mime-type-string)))

2694

(t

2695

                                         (log-warn "Unsupported mime type: ~s." accept-mime-type-string)

2696

nil))

2697

when (find accept-mime-type mime-types)

2698

do (return accept-mime-type)

2699

finally (return (first mime-types)))))

2700

 ;;; (select-mime-type "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8,application/rdf+xml;q=0.93,text/rdf+n3;q=0.5" (list mime:text/plain mime:application/link-format mime:*/*))

2701

;;; (select-mime-type "" (list mime:text/plain mime:application/link-format mime:*/*))

2702

2703

;;;

2704

2705

(defun main-echo (&rest args &key

2706

(query-parameters (sb-posix:getenv "QUERY_STRING"))

2707

((:response-content-type *response-content-type*) mime:text/plain)

2708

&allow-other-keys)

2709

(handler-bind ((serious-condition

2710

(lambda (condition)

2711

                     (log-stacktrace "Error request thread: ~a -> ~a." query-parameters condition)

2712

                     (format *standard-output* "<html><body><pre>~a</pre></body></html>" condition)

2713

(stop)

2714

(return-from main-echo))))

2715

(initialize-spocq :title (or (getarg "--title") "spocqecho"))

2716

;; allow request query arguments to override the static script arguments

2717

(let ((combined-args (append (parse-query-parameters query-parameters) args)))

2718

(with-command-line-configuration (combined-args)

2719

(setq *start-timestamp* (iso-time))

2720

(log-info "Start echo ~a." *start-timestamp*)

2721

(format *standard-output* "~%comamnd-line configuration:~%~s~%" *request-configuration*)

2722

(format *standard-output* "~%function arguments:~%~s~%" combined-args)

2723

(format *standard-output* "~%*metadata*~%~s~%" *metadata*)

2724

(when *repository-id*

2725

           (format *standard-output* "~%repository~%~s~%" (instance-metadata (repository *repository-id*)))))

2726

(stop))))

2727

2728

2729

(defun print-configuration (&key (stream *standard-output*))

2730

(map nil #'(lambda (setting) (print setting stream))

2731

`((:request-content-type ,*request-content-type*)

2732

(:response-content-type ,*response-content-type*))))

2733

2734

#|

2735

2736

 QUERY_STRING='api-key=key&base-iri=http://example.org&skolemize-prefix=ppp&skolemize=skolemize&default-context-term=urn:dydra:all&

2737

  describe-form=symmetric&describe-object-depth=4&describe-subject-depth=3&dynamic-bindings=((var1)%20(4))&end-time=2013-01-01T17:17:00Z&

2738

  federation-mode=external&memory-limit=1&named-contexts-term=all&namespace-bindings=((ns1%20"http://ns1/org"))&operation=none&

2739

  provenance-repository=123&signature=999999&repository=jhacker/test-load&request-content-type=text/plain&response-limit=32&response-off-set=33&

2740

revision-id=00000000-1111-2222-333333333333&request-routing-key=no-key&request-exchange=no-exchange&

2741

  library-path=http://set1%20http://set2&start-time=2013-01-01T00:00:00Z&task-id=00000000-1111-2222-444444444444&time-interval=44&time-limit=33&

2742

trace-routing-key=no-key&undefined-variable-behavior=warn&user-id=no-user-id' \

2743

sbcl --core /development/source/library/sbcl-spocq.core \

2744

--eval '(progn (spocq.i::main-echo))'

2745

2746

 (main-echo :query-parameters "api-key=key&base-iri=http://example.org&skolemize-prefix=ppp&skolemize=skolemize&default-context-term=urn:dydra:all&

2747

  describe-form=symmetric&describe-object-depth=4&describe-subject-depth=3&dynamic-bindings=((var1)%20(4))&end-time=2013-01-01T17:17:00Z&

2748

  federation-mode=external&memory-limit=1&named-contexts-term=all&namespace-bindings=((ns1%20\"http://ns1/org\"))&operation=none&

2749

  provenance-repository=123&signature=999999&repository=jhacker/test-load&request-content-type=text/plain&response-limit=32&response-off-set=33&

2750

revision-id=00000000-1111-2222-333333333333&request-routing-key=no-key&request-exchange=no-exchange&

2751

  library-path=http://set1%20http://set2&start-time=2013-01-01T00:00:00Z&task-id=00000000-1111-2222-444444444444&time-interval=44&time-limit=33&

2752

trace-routing-key=no-key&undefined-variable-behavior=warn&user-id=no-user-id")

2753

2754

2755

QUERY_STRING='api-key=key&repository=jhacker/726-base&request-content-type=text/plain' \

2756

sbcl --core /development/source/library/sbcl-spocq.core \

2757

--eval '(progn (spocq.i::main-echo))'

2758

2759

(encode-presentation-graph (instance-metadata (account "jhacker")))

2760

|#