Coverage report: /development/source/library/org/datagraph/spocq-shard/src/odbc/views.lisp

Kind	Covered	All	%
expression	441	859	51.3
branch	12	36	33.3

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

;;; Provide access to legacy mysql queries table as one of two definitions for views.

4

;;;

5

;;; Each account's respective system repository includes shadow definitions for

6

;;; use through the sparql interface.

7

;;;

8

;;; sql records are a part of the standard rails mysql complement.

9

;;; this interface supports means to manipulate them through the sparq http service

10

;;;

11

;;; read-sql-account

12

;;; read-sql-repository

13

;;; read-sql-query

14

;;; write-sql-query

15

;;; delete-sql-query

16

;;;

17

;;; read-view-sql-definition

18

;;; write-view-sql-definition

19

;;; delete-view-sql-definition

20

;;; view-sql-definition-exists-p

21

22

;;; (load "./patches/views.lisp")

23

24

#|

25

mysql> describe queries;

26

+---------------+--------------+------+-----+---------+----------------+

27

28

+---------------+--------------+------+-----+---------+----------------+

29

| id | int(11) | NO | PRI | NULL | auto_increment |

30

| uuid | varchar(255) | YES | | NULL | |

31

| name | varchar(255) | YES | MUL | NULL | |

32

| repository_id | int(11) | YES | | NULL | |

33

| account_id | int(11) | YES | | NULL | |

34

 | summary       | text         | YES  |     | NULL    |                |

35

| query_text | text | YES | | NULL | |

36

| cached_slug | varchar(255) | YES | MUL | NULL | |

37

+---------------+--------------+------+-----+---------+----------------+

38

39

(trace WRITE-SQL-QUERY CLSQL-SYS:EXECUTE-COMMAND READ-SQL-QUERY

40

CLSQL-SYS:UPDATE-RECORDS-FROM-INSTANCE

41

WRITE-VIEW-SQL-DEFINITION READ-SQL-REPOSITORY)

42

|#

43

44

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

45

46

;;; when used on an older mysql schema, this must be removed and the respective operators redefined

47

(eval-when (:compile-toplevel :load-toplevel :execute)

48

(pushnew :extended-view-metadata *features*))

49

50

(unless (fboundp 'view-summary)

51

(defclass view (linked-resource identified-object)

52

((repository

53

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

54

:reader view-repository)

55

(name

56

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

57

:reader view-name)

58

#+extended-view-metadata

59

(uuid

60

:initarg :uuid :initform nil

61

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

62

(query

63

:initarg :query :initform nil

64

:reader get-view-query

65

:writer (setf view-query))

66

(sse-expression

67

:initarg :sse-expression :initform nil

68

:reader get-view-sse-expression

69

:writer (setf view-sse-expression))

70

(options

71

:initarg :options :initform nil

72

:reader get-view-options

73

:writer (setf view-options))

74

(dimensions

75

:initarg :dimensions :initform nil

76

:reader get-view-dimensions

77

:writer (setf view-dimensions))

78

(parameters

79

:initarg :parameters :initform nil

80

:reader view-parameters)

81

#+extended-view-metadata

82

(summary

83

:initarg :summary :initform nil

84

:accessor view-summary))))

85

86

(unless (fboundp 'parse-view-identifier)

87

(defparameter *view-identifier-scanner*

88

(cl-ppcre:create-scanner `(:sequence :start-anchor

89

(:greedy-repetition 0 1 (:sequence

90

                                                                 (:greedy-repetition 0 1 (:sequence

91

                                                                                          (:alternation "http" "https")

92

                                                                                          "://"

93

                                                                                          (:greedy-repetition 1 nil (:inverted-char-class #\/))))

94

                                                                 #\/))

95

                                        (:register (:greedy-repetition 1 nil (:inverted-char-class #\/)))

96

#\/

97

                                        (:register (:greedy-repetition 1 nil (:inverted-char-class #\/)))

98

#\/

99

                                        (:register (:greedy-repetition 1 nil (:inverted-char-class #\.)))

100

                                        (:register (:greedy-repetition 0 1 (:sequence #\. (:GREEDY-REPETITION 0 NIL :EVERYTHING))))

101

:end-anchor))

102

"regex scanner for view identifiers")

103

(macrolet ((def-regex-parser (name (parameter &optional (required t)) &rest args)

104

(let ((documentation (when (stringp (first args)) (pop args)))

105

(scanner (pop args)))

106

`(defgeneric ,name (,parameter &key junk-allowed)

107

,@(when documentation `((:documentation ,documentation)))

108

(:method ((,parameter string) &key (junk-allowed ,(not required)))

109

                     (multiple-value-bind (parse registers) (cl-ppcre:scan-to-strings ,scanner ,parameter)

110

(cond (parse

111

,@args

112

                              (apply #'values (loop for element across registers collect (when (plusp (length element)) element))))

113

(junk-allowed

114

nil)

115

(t

116

                              (error ,(format nil "~a: invalid value: ~~s" name) ,parameter)))))

117

(:method ((,parameter spocq:iri) &rest args)

118

(declare (dynamic-extent args))

119

(apply #',name (spocq:iri-lexical-form ,parameter) args))

120

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

121

(declare (dynamic-extent args))

122

(apply #',name (iri-lexical-form ,parameter) args))

123

(:method ((,parameter t) &key (junk-allowed ,(not required)))

124

(unless junk-allowed

125

(error ,(format nil "~a: invalid value: ~~s" name) ,parameter))

126

nil)))))

127

(def-regex-parser parse-view-identifier (namestring nil)

128

"Return the components of a view identifier"

129

*view-identifier-scanner*)))

130

(unless (fboundp 'spocq.e::account-not-found-error)

131

(define-condition spocq.e::account-not-found-error (spocq.e:resource-not-found-error)

132

())

133

134

(defun spocq.e::account-not-found-error (&rest args)

135

(apply #'error 'spocq.e::account-not-found-error

136

args)))

137

138

;; even though it is a read-only view

139

(clsql:def-view-class |queries| ()

140

((id

141

:db-kind :key

142

:db-constraints :auto-increment

143

:type integer :initform nil

144

:reader sql-query-id

145

:documentation "Auto-generated ordinal id")

146

#+extended-view-metadata

147

(uuid

148

:type (clsql-sys:varchar 255)

149

:initarg :uuid

150

:accessor sql-query-uuid

151

:documentation "An UUID string incorporated when the query is first saved.

152

Permits stable identifiation when the name is changed.")

153

(name

154

:db-kind :key

155

:type (clsql-sys:varchar 255)

156

:initarg :name

157

:accessor sql-query-name

158

:documentation "The name used to edit and execute the view.")

159

(repository_id

160

:db-kind :key

161

:type integer :initform nil

162

:initarg :repository-id

163

:accessor sql-query-repository-id)

164

(repository

165

:reader sql-query-repository

166

:db-kind :join

167

:db-info (:join-class |repositories|

168

:home-key repository_id

169

:foreign-key id

170

:set t))

171

(account_id

172

:db-kind :key

173

:type integer :initform nil

174

:initarg :account-id

175

:accessor sql-query-account-id)

176

(account

177

:reader sql-query-account

178

:db-kind :join

179

:db-info (:join-class |accounts|

180

:home-key account_id

181

:foreign-key id

182

:set t))

183

#+extended-view-metadata

184

(summary

185

:type (clsql-sys:varchar 65535)

186

:initarg :summary

187

:accessor sql-query-summary)

188

(query_text

189

:type (clsql-sys:varchar 65535)

190

:initarg :text

191

:accessor sql-query-text

192

:documentation "The SPARQL query text")

193

(cached_slug

194

:db-kind :key

195

:type (clsql-sys:varchar 255)

196

:initarg :cached-slug

197

:accessor sql-query-cached-slug))

198

(:base-table |queries|)

199

(:documentation "The SQL-QUERY class defines the access interface to the

200

queries table. It includes the foreign key relations via the respective

201

id fields to the accountd and repositories table to permit queries in

202

terms of the respective names."))

203

204

(clsql:def-view-class |repositories| ()

205

((id :type integer

206

:reader sql-repository-id

207

:db-kind :key)

208

(uuid :type (clsql-sys:varchar 255)

209

:reader sql-repository-uuid

210

:initarg :uuid)

211

(name :type (clsql-sys:varchar 255)

212

:reader sql-repository-name

213

:initarg :name)

214

(account_id :type integer

215

:accessor sql-repository-account-id

216

:initarg :account-id)

217

(account

218

:initarg :account

219

:accessor sql-repository-account

220

:db-kind :join

221

:db-info (:join-class |accounts|

222

:home-key account_id

223

:foreign-key id

224

:set t))

225

(license_id :type integer

226

:accessor sql-repository-license-id)

227

(homepage :type (clsql-sys:varchar 255)

228

:accessor sql-repository-homepage)

229

(summary :type (clsql-sys:varchar 65535)

230

:accessor sql-repository-summary)

231

(description :type (clsql-sys:varchar 65535)

232

:accessor sql-repository-description)

233

(cached_slug :type (clsql-sys:varchar 255)

234

:accessor sql-repository-cached-slug)

235

(privacy_setting :type integer

236

:accessor sql-repository-privacy-setting)

237

(permissable_ip_addresses :type (clsql-sys:varchar 65535)

238

:accessor sql-repository-permissible-ip-addresses)

239

(default_repository_prefixes :type (clsql-sys:varchar 65535)

240

:accessor sql-repository-default-repository-prefixes))

241

(:base-table |repositories|)

242

(:documentation "The SQL-REPOSITORY class defines enough of the

243

repository table to provide a join target for queries against the

244

queries table."))

245

246

(clsql:def-view-class |accounts| ()

247

((id :type integer

248

:reader sql-account-id

249

:db-kind :key)

250

(email :type (clsql-sys:varchar 255))

251

(encrypted_password :type (clsql-sys:varchar 255)

252

:initarg :encrypted-password)

253

(authentication_token :type (clsql-sys:varchar 255)

254

:initarg :authentication-token)

255

(remember_created_at :type clsql-sys::timestamp)

256

(reset_password_token :type (clsql-sys:varchar 255))

257

(name :type (clsql-sys:varchar 255)

258

:initarg :name

259

:reader sql-account-name)

260

(fullname :type (clsql-sys:varchar 255))

261

;; (admin :type clsql-sys:tinyint) removed in rails @ 20150426022900_remove_accounts_admin_field

262

(cached_slug :type (clsql-sys:varchar 255))

263

(request_timeout_limit :type integer)

264

(default_repository_prefixes :type (clsql-sys:varchar 65535))

265

(homepage :type (clsql-sys:varchar 63))

266

(blog :type (clsql-sys:varchar 63))

267

(company :type (clsql-sys:varchar 63))

268

(location :type (clsql-sys:varchar 63))

269

(phone :type (clsql-sys:varchar 63))

270

(skype_id :type (clsql-sys:varchar 63))

271

(jabber_id :type (clsql-sys:varchar 63))

272

(region :type (clsql-sys:varchar 15))

273

(host :type (clsql-sys:varchar 63)))

274

(:base-table |accounts|)

275

(:documentation "The SQL-ACCOUNT class defines enough of the

276

accounts table to provide a join target for queries against the

277

queries table."))

278

279

(defparameter *license-registry* nil)

280

(defun license-registry ()

281

(cond (*license-registry*)

282

(t

283

(let ((registry (make-hash-table :test 'equalp)))

284

(handler-case (loop for license in (parse-json #p"/opt/rails/config/licenses.json")

285

                            for id = (rest (assoc "id" license :test #'string-equal))

286

                            for url = (rest (assoc "url" license :test #'string-equal))

287

                            for name = (rest (assoc "name" license :test #'string-equal))

288

do (setf (gethash id registry) url

289

(gethash (write-to-string id) registry) id

290

(gethash name registry) id

291

(gethash url registry) id))

292

(error () (log-warn "license-registry: failed to load registry.")))

293

(setq *license-registry* registry)))))

294

295

(defmethod print-object ((object |queries|) (stream t))

296

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

297

(format stream "~a[~a.~a.~a]"

298

(bound-slot-value object 'name)

299

(bound-slot-value object 'account_id)

300

(bound-slot-value object 'repository_id)

301

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

302

(defmethod print-object ((object |repositories|) (stream t))

303

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

304

(format stream "~a[~a.~a]"

305

(bound-slot-value object 'name)

306

(bound-slot-value object 'account_id)

307

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

308

(defmethod print-object ((object |accounts|) (stream t))

309

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

310

(format stream "~a[~a]"

311

(bound-slot-value object 'name)

312

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

313

314

315

(defun make-sql-query (&rest args)

316

"Create an |queries| instance"

317

(declare (dynamic-extent args))

318

(apply #'make-instance '|queries| args))

319

320

(defun make-sql-repository (&rest args)

321

"Create an |repositories| instance"

322

(declare (dynamic-extent args))

323

(apply #'make-instance '|repositories| args))

324

325

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

326

"Create an |accounts| instance"

327

(declare (dynamic-extent args))

328

(apply #'make-instance '|accounts| args))

329

330

331

(defun sql-query-database-definition (&optional (db-name *MYSQL-DATABASE*) (user "root") (password nil))

332

"Return CLSQL database connection definition specific to the query view tables

333

given the name, user and password."

334

;; both postgres and mysql follow the same naming convention

335

;; on mysql the super-user is "root", the standard user "production"

336

`("localhost" ,db-name ,user ,password))

337

338

(defmacro with-sql-query-database-transaction ((db) &body body)

339

(let ((op (gensym "sql-query")))

340

`(flet ((,op (,db)

341

(declare (ignorable ,db))

342

,@body))

343

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

344

(call-with-sql-query-database-transaction #',op))))

345

346

(defun call-with-sql-query-database-transaction (op)

347

(declare (dynamic-extent op))

348

(clsql:with-database (db (sql-query-database-definition) :database-type :mysql)

349

(clsql-sys:with-default-database (db)

350

(clsql-sys:database-execute-command "SET NAMES utf8" db)

351

(clsql-sys:with-transaction (:database db)

352

(funcall op db)))))

353

354

355

356

;;;

357

;;; read operations on accounts/repositories/queries tables

358

;;; update/delete for the query table only

359

360

(defun read-sql-account (&key name id)

361

(with-sql-query-database-transaction (db)

362

(first (clsql:select '|accounts| :database db :where

363

(if id

364

                                (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'ID) id)

365

(CLSQL-SYS:SQL-OR

366

                                 (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'NAME) name)

367

                                 (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'CACHED_SLUG) name)))

368

:flatp t))))

369

;;; (read-sql-account :name "james")

370

;;; (read-sql-account :id 4)

371

372

(defun write-sql-account (sql-account)

373

"Modify the sql record for the account.

374

Insert a new record if none was present."

375

(handler-case

376

(with-sql-query-database-transaction (db)

377

;;(clsql:set-autocommit nil :database db)

378

(clsql:update-records-from-instance sql-account :database db)

379

;(clsql:commit db)

380

sql-account)

381

(error (c)

382

(log-error "write-sql-account: failed to store account: ~s: ~a" sql-account c)

383

nil)))

384

385

386

(defun read-sql-repository (&key name account-name id)

387

(with-sql-query-database-transaction (db)

388

(first (clsql:select '|repositories| :database db :where

389

(if id

390

                              (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'ID) id)

391

(CLSQL-SYS:SQL-AND

392

(CLSQL-SYS:SQL-OR

393

                                (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'NAME) name)

394

                                (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'CACHED_SLUG) name))

395

(CLSQL-SYS:SQL-AND

396

                                (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'ID)

397

                                                 (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'account_ID))

398

(CLSQL-SYS:SQL-OR

399

                                 (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'NAME) account-name)

400

                                 (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'CACHED_SLUG) account-name)))))

401

:flatp t))))

402

;;; (read-sql-repository :name "foaf" :account-name "james")

403

;;; (read-sql-repository :id 23)

404

405

(defun write-sql-repository (sql-repository)

406

"Modify the sql record for the repository.

407

Insert a new record if none was present."

408

(handler-case

409

(with-sql-query-database-transaction (db)

410

;;(clsql:set-autocommit nil :database db)

411

(clsql:update-records-from-instance sql-repository :database db)

412

;(clsql:commit db)

413

sql-repository)

414

(error (c)

415

(log-error "write-sql-repository: failed to store repository: ~s: ~a" sql-repository c)

416

nil)))

417

418

(defun delete-sql-repository (sql-repository)

419

"Delete the sql record for the repository."

420

(handler-case

421

(with-sql-query-database-transaction (db)

422

(clsql:delete-instance-records sql-repository :database db)

423

sql-repository)

424

(error (c)

425

            (log-error "delete-sql-repository: failed to delete repository: ~s: ~a" sql-repository c)

426

nil)))

427

428

(defparameter *read-sql-query-lock* (bt:make-lock "read query"))

429

430

(defun read-sql-query (&key repository-name account-name name id uuid)

431

"Construct and return an SQL-SQUERY instance record given alternatively

432

- the id

433

- the uuid

434

- the combined account, repository, and name"

435

(bt:with-lock-held (*read-sql-query-lock*)

436

(with-sql-query-database-transaction (db)

437

(first (clsql:select '|queries| :database db :where

438

(cond (id

439

                                 (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|queries| 'ID) id))

440

(uuid

441

                                 (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|queries| 'UUID) uuid))

442

(t

443

(CLSQL-SYS:SQL-AND

444

(CLSQL-SYS:SQL-AND

445

(CLSQL-SYS:SQL-AND

446

(CLSQL-SYS:SQL-=

447

                                     (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'ID)

448

                                     (CLSQL-SYS:SQL-SLOT-VALUE '|queries| 'REPOSITORY_ID))

449

(CLSQL-SYS:SQL-OR

450

                                     (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'NAME) repository-name)

451

                                     (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'CACHED_SLUG) repository-name)))

452

(CLSQL-SYS:SQL-AND

453

(CLSQL-SYS:SQL-=

454

(CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'ID)

455

                                     ;; must use the repository account id to use it as the context

456

                                     ;; rather than the query creator's account

457

                                     (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'account_ID))

458

(CLSQL-SYS:SQL-OR

459

                                     (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'NAME) account-name)

460

                                     (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'CACHED_SLUG) account-name))))

461

(CLSQL-SYS:SQL-OR

462

                                   (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|queries| 'NAME) name)

463

                                   (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|queries| 'CACHED_SLUG) name)))))

464

:flatp t)))))

465

 ;;; (read-sql-query :name "new" :repository-name "foaf" :account-name "james") ; same query and repository owner

466

 ;;; (read-sql-query :name "all-no-limit" :repository-name "mem-rdf" :account-name "openrdf-sesame") ; different query and repository owner

467

468

(defun write-sql-query (sql-query)

469

"Modify the sql record for the query.

470

Insert a new record if none was present."

471

(handler-case

472

(with-sql-query-database-transaction (db)

473

;;(clsql:set-autocommit nil :database db)

474

(clsql:update-records-from-instance sql-query :database db)

475

;(clsql:commit db)

476

sql-query)

477

(error (c)

478

(log-error "update-sql-query: failed to store query: ~s: ~a" sql-query c)

479

nil)))

480

481

(defun delete-sql-query (sql-query)

482

"Delete the sql record for the query."

483

(handler-case

484

(with-sql-query-database-transaction (db)

485

(clsql:delete-instance-records sql-query :database db)

486

sql-query)

487

(error (c)

488

(log-error "delete-sql-query: failed to delete query: ~s: ~a" sql-query c)

489

nil)))

490

491

(defun read-sql-query-names (&key repository-name account-name)

492

"Construct and return an SQL-SQUERY instance record given alternatively

493

- the id

494

- the uuid

495

- the combined account, repository, and name"

496

(with-sql-query-database-transaction (db)

497

(clsql:select '|queries| :database db :where

498

(CLSQL-SYS:SQL-AND

499

(CLSQL-SYS:SQL-AND

500

(CLSQL-SYS:SQL-=

501

(CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'ID)

502

(CLSQL-SYS:SQL-SLOT-VALUE '|queries| 'REPOSITORY_ID))

503

(CLSQL-SYS:SQL-OR

504

                      (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'NAME) repository-name)

505

                      (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'CACHED_SLUG) repository-name)))

506

(CLSQL-SYS:SQL-AND

507

(CLSQL-SYS:SQL-=

508

(CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'ID)

509

;; must use the repository account id to use it as the context

510

;; rather than the query creator's account

511

(CLSQL-SYS:SQL-SLOT-VALUE '|repositories| 'account_ID))

512

(CLSQL-SYS:SQL-OR

513

                      (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'NAME) account-name)

514

                      (CLSQL-SYS:SQL-= (CLSQL-SYS:SQL-SLOT-VALUE '|accounts| 'CACHED_SLUG) account-name))))

515

:flatp t)))

516

;;;

517

;;; create/read/update/delete operations on views as surrogates for just the query table

518

519

520

(defgeneric read-view-sql-definition (view)

521

(:documentation "Read just the sql-based view definition and bind the relevant attributes.

522

Return the view, if defined, otherwise return nill and leave the instance unmodified.")

523

(:method ((view view))

524

(let* ((name (view-name view))

525

(account-name (account-name (repository-account (view-repository view))))

526

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

527

(sql-query (read-sql-query :repository-name repository-name

528

:account-name account-name

529

:name name)))

530

(labels ((unescape-mysql-char (target-string start end match-start match-end reg-starts reg-ends)

531

(declare (ignore start end match-end reg-starts reg-ends))

532

(let ((char (char target-string (1+ match-start))))

533

(case char

534

(#\b #.(make-string 1 :initial-element #\backspace))

535

(#\n #.(make-string 1 :initial-element #\newline))

536

(#\r #.(make-string 1 :initial-element #\return))

537

(#\t #.(make-string 1 :initial-element #\tab))

538

(t (make-string 1 :initial-element char)))))

539

(unescape-mysql-string (string)

540

(when string

541

                    (cl-ppcre:regex-replace-all (load-time-value (cl-ppcre:create-scanner "\\\\."))

542

string

543

                                                #'unescape-mysql-char))))

544

(when sql-query

545

#+extended-view-metadata

546

(setf-view-uuid (sql-query-uuid sql-query) view)

547

           (setf (view-query view)  (sql-query-text sql-query) #+(or)(unescape-mysql-string (sql-query-text sql-query)))

548

#+extended-view-metadata

549

(setf (view-summary view) (sql-query-summary sql-query))

550

view)))))

551

552

553

(defgeneric write-view-sql-definition (view)

554

(:documentation "Given a view, write its definition through an sql-query instance to

555

the queries table.")

556

(:method ((view view))

557

(let* ((name (view-name view))

558

(account-name (account-name (repository-account (view-repository view))))

559

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

560

(sql-query (read-sql-query :repository-name repository-name

561

:account-name account-name

562

:name name))

563

(sql-query-text (get-view-query view)

564

#|(with-output-to-string (stream)

565

                              (loop for char across (trim-string-whitespace (get-view-query view))

566

do (case char

567

(#\backspace (write-string "\\b" stream))

568

(#\newline (write-string "\\n" stream))

569

(#\return (write-string "\\r" stream))

570

(#\tab (write-string "\\t" stream))

571

(t (write-char char stream)))))|#))

572

(cond (sql-query

573

(when (get-view-query view)

574

(setf (sql-query-text sql-query) sql-query-text))

575

(when (view-summary view)

576

(setf (sql-query-summary sql-query) (view-summary view))))

577

578

(t

579

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

580

                     (sql-repository (read-sql-repository :name repository-name :account-name account-name))

581

(uuid (make-v1-uuid-string)))

582

(unless sql-account

583

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

584

(unless sql-repository

585

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

586

(setf sql-query (make-sql-query

587

:uuid uuid

588

:name name

589

:text sql-query-text

590

:cached-slug name

591

:repository sql-repository

592

:repository-id (sql-repository-id sql-repository)

593

:account sql-account

594

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

595

:summary (view-summary view)))

596

(setf-view-uuid uuid view))))

597

(write-sql-query sql-query))))

598

599

600

(defgeneric delete-view-sql-definition (view)

601

(:documentation "Given a view, delete its definition through an sql-query instance from

602

the queries table.")

603

(:method ((view view))

604

(let* ((name (view-name view))

605

(account-name (account-name (repository-account (view-repository view))))

606

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

607

(sql-query (read-sql-query :repository-name repository-name

608

:account-name account-name

609

:name name)))

610

(cond (sql-query

611

(delete-sql-query sql-query)

612

view)))))

613

614

615

(defgeneric view-sql-definition-exists-p (view)

616

(:method ((designator SPOCQ:HTTP-URL))

617

(multiple-value-bind (repository-name account-name view-name file-type)

618

(parse-view-identifier (iri-lexical-form designator))

619

(declare (ignore file-type))

620

(when (and repository-name account-name view-name)

621

         (view-sql-definition-exists-p (make-view :repository (repository (make-repository-id :repository-name repository-name

622

                                                                               :account-name account-name))

623

:name view-name)))))

624

(:method ((designator spocq:uuid))

625

(not (null (read-sql-query :uuid (iri-lexical-form designator)))))

626

627

(:method ((view view))

628

(let* ((name (view-name view))

629

(account-name (account-name (repository-account (view-repository view))))

630

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

631

(not (null (read-sql-query :repository-name repository-name

632

:account-name account-name

633

:name name))))))

634

635

636

;;;

637

;;; operations on views sql+sparql

638

639

(defparameter *built-in-views* (make-hash-table :test 'equalp))

640

641

(setf (gethash "all" *built-in-views*)

642

"select * where { {?s ?p ?o} union { graph ?g {?s ?p ?o} } }")

643

;; this requires access to the system/system repository, but that is reserved for admins

644

(setf (gethash "system-rbac" *built-in-views*)

645

"construct { ?node ?property ?value .

646

?value <http://purl.org/dc/elements/1.1/title> ?title .

647

?value a ?type .

648

?group <http://www.w3.org/ns/prov#hadMember> ?value }

649

where {

650

{ { graph ?g1 { { ?node <http://www.w3.org/ns/auth/acl#accessTo> ?resource .

651

?node ?property ?value }

652

optional

653

{ ?value a ?type } } }

654

optional

655

{ ?value <http://www.w3.org/ns/prov#hadMember> ?member}

656

optional

657

{ service <http://localhost/system/system>

658

              { graph ?g2 { ?value a ?type . ?value <http://purl.org/dc/elements/1.1/title> ?title } } } }

659

union

660

{ service <http://localhost/system/system> { ?value a ?type } }

661

}")

662

(setf (gethash "account-rbac" *built-in-views*)

663

"construct { ?node ?property ?value .

664

?value a ?type .

665

?value <http://www.w3.org/ns/prov#hadMember> ?member}

666

where {

667

{ graph ?g1 { { ?node <http://www.w3.org/ns/auth/acl#accessTo> ?resource .

668

?node ?property ?value }

669

optional

670

{ ?value a ?type } } }

671

optional

672

{ ?value <http://www.w3.org/ns/prov#hadMember> ?member }

673

}")

674

;;; (test-sparql (gethash "account-rbac" *built-in-views*) :repository-id "test/system")

675

;;; (test-sparql (gethash "system-rbac" *built-in-views*) :repository-id "test/system")

676

 ;;; (test-sparql "construct {?type a ?class} where { service <http://localhost/system/system> {?type a ?class}}" :repository-id "system/system")

677

678

 ;;; (test-sparql "select * where {graph ?g { ?s a <urn:dydra:View> . ?s ?p ?o}}" :repository-id "james/system")

679

 ;;; (test-sparql "select * where {graph ?g { ?v a <urn:dydra:View> . ?a <http://www.w3.org/ns/auth/acl#accessTo> ?v}}" :repository-id "james/system")

680

681

(defgeneric read-view-definition (view)

682

#+(or) ;;; mysql based version

683

(:method ((view view))

684

(let* ((repository (view-repository view))

685

(repository-name (repository-name repository))

686

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

687

(view-name (view-name view)))

688

(flet ((get-view-definition ()

689

              (let* ((query (format nil "SELECT q.query_text AS text FROM queries q LEFT JOIN repositories r ON q.repository_id = r.id LEFT JOIN accounts a ON r.account_id = a.id WHERE a.cached_slug = '~a' AND r.cached_slug = '~a' AND q.cached_slug = '~a' LIMIT 1"

690

account-name repository-name view-name))

691

(command (format nil "mysql -h ~a -u root ~a -BNe \"~a;\""

692

                                      spocq.i::*mysql-host* spocq.i::*mysql-database* query))

693

(process

694

(run-program "/bin/sh" (list "-c" command)

695

:input nil :output :stream

696

:wait nil))

697

(result-stream (run-program-output process)))

698

(unwind-protect

699

(let ((query-text (read-line result-stream nil)))

700

                      (flet ((unescape-mysql (target-string start end match-start match-end reg-starts reg-ends)

701

                               (declare (ignore start end match-end reg-starts reg-ends))

702

(let ((char (char target-string (1+ match-start))))

703

(case char

704

                                   (#\b #.(make-string 1 :initial-element #\backspace))

705

                                   (#\n #.(make-string 1 :initial-element #\newline))

706

                                   (#\r #.(make-string 1 :initial-element #\return))

707

(#\t #.(make-string 1 :initial-element #\tab))

708

(t (make-string 1 :initial-element char))))))

709

(when query-text

710

                        (cl-ppcre:regex-replace-all (load-time-value (cl-ppcre:create-scanner "\\\\."))

711

query-text

712

                                                    #'unescape-mysql))))

713

(progn

714

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

715

(or (get-view-definition)

716

(gethash (view-name view) *static-views*)))))

717

(:method ((view view)) ;; as long as the sql+sparql definition exists

718

(let ((view-name (view-name view)))

719

(cond ((gethash view-name *built-in-views*)

720

(setf-view-uuid "" view)

721

(setf (view-query view) (gethash view-name *built-in-views*))

722

(setf (view-summary view) "builtin")

723

view)

724

(t

725

(read-view-sql-definition view))))))

726

727

(defgeneric read-repository-view-definitions (view)

728

(:documentation "Read just the sql-based view definition and bind the relevant attributes.

729

Return the view, if defined, otherwise return nill and leave the instance unmodified.")

730

(:method ((repository repository))

731

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

732

(repository-name (repository-name repository))

733

(sql-queries (read-sql-query-names :repository-name repository-name

734

                                               :account-name account-name)))

735

(loop for sql-query in sql-queries

736

collect

737

#+extended-view-metadata

738

(make-view :repository repository

739

:name (sql-query-name sql-query)

740

:uuid (sql-query-uuid sql-query)

741

:query (sql-query-text sql-query)

742

:summary (sql-query-summary sql-query))

743

#-extended-view-metadata

744

(make-view :repository repository

745

:name (sql-query-name sql-query)

746

:query (sql-query-text sql-query))))))

747

748

749

(defgeneric write-view-definition (view)

750

(:method ((view view))

751

(let* ((exists (view-sql-definition-exists-p view))

752

(view-uri (view-identifier view))

753

(repository (view-repository view))

754

(repository-uri (repository-identifier repository))

755

(account (repository-account repository))

756

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

757

(write-view-sql-definition view)

758

;; write rdf definition

759

(if exists ;; modify just the text

760

           (let ((delete-graph `((spocq.a:|quad| ,view-uri <http://spinrdf.org/sp#text> ?::text ,repository-uri)))

761

                 (insert-graph `((spocq.a:|quad| ,view-uri <http://spinrdf.org/sp#text> ,(view-query view) ,repository-uri))))

762

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

763

(repository-delete-field system-repository delete-graph)

764

(repository-insert-field system-repository insert-graph)

765

;; no (commit-transaction *transaction*)

766

))

767

(let* ((owner-uri (account-identifier account))

768

(agent-uri (when *agent* (agent-identifier *agent*)))

769

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

770

                  (quads `((spocq.a:|quad| ,view-uri |rdf|:|type| |urn:dydra|:|View| ,repository-uri)

771

                           (spocq.a:|quad| ,view-uri |foaf|:|name| ,(view-name view) ,repository-uri)

772

                           (spocq.a:|quad| ,view-uri <http://spinrdf.org/sp#text> ,(view-query view) ,repository-uri)

773

,@(when (view-summary view)

774

                               `((spocq.a:|quad| ,view-uri |dc|:|description| ,(view-summary view) ,repository-uri)))

775

                           ,@(if (and *agent* (not (equalp (user-name *agent*) (account-name account))))

776

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

777

                                   `((spocq.a:|quad| ,view-uri |sioc|:|has_owner| ,agent-uri ,repository-uri)

778

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

779

                                     (spocq.a:|quad| ,agent-access-node |acl|:|mode| |acl|:|Read| ,repository-uri)

780

                                     (spocq.a:|quad| ,agent-access-node |acl|:|mode| |acl|:|Write| ,repository-uri)

781

                                     (spocq.a:|quad| ,agent-access-node |acl|:|mode| |acl|:|Execute| ,repository-uri)

782

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

783

                                 `((spocq.a:|quad| ,view-uri |sioc|:|has_owner| ,owner-uri ,repository-uri)))

784

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

785

                           (spocq.a:|quad| ,owner-access-node |acl|:|mode| |acl|:|Read| ,repository-uri)

786

                           (spocq.a:|quad| ,owner-access-node |acl|:|mode| |acl|:|Write| ,repository-uri)

787

                           (spocq.a:|quad| ,owner-access-node |acl|:|mode| |acl|:|Execute| ,repository-uri)

788

                           (spocq.a:|quad| ,owner-access-node |acl|:|agent| ,owner-uri ,repository-uri))))

789

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

790

(repository-insert-field *transaction* quads)

791

;; no (commit-transaction *transaction*)

792

))))))

793

794

 ;;; (write-view-definition (make-instance 'view :repository (repository "test/test") :name "test" :query "select * where {?s ?p ?o}"))

795

;;; (repository-view (repository "test/test") "test")

796

797

(defgeneric delete-view-definition (view &optional force)

798

(:documentation "Delete the sql record and the system metadata for the view.

799

    Authentication is not controled here execpt for that implicit in the system repository transaction")

800

(:method ((view view) &optional (force nil))

801

(let* ((exists (view-sql-definition-exists-p view))

802

(view-uri (view-identifier view))

803

(repository (view-repository view))

804

(repository-uri (repository-identifier repository))

805

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

806

(when (or exists force)

807

(delete-view-sql-definition view)

808

(run-sparql-internal

809

`(spocq.a:|update|

810

(spocq.a:|modify|

811

(spocq.a:|graph| ,repository-uri

812

(spocq.a:|union|

813

(spocq.a:|bgp| (spocq.a:|triple| ,view-uri ?::|p| ?::|o|))

814

(spocq.a:|bgp| (spocq.a:|triple| ?::|acl| |acl|:|accessTo| ?::|view|)

815

(spocq.a:|triple| ?::|acl| ?::|p| ?::|o|))))

816

:DELETE

817

((spocq.a:|graph| ,repository-uri

818

((spocq.a:|triple| ,view-uri ?::|p| ?::|o|)

819

(spocq.a:|triple| ?::|acl| ?::|p| ?::|o|))))))

820

:repository-id system-repository-id

821

:agent *agent*)))))

822

#+(or)

823

(parse-sparql "

824

delete { graph ?repo { ?view ?p ?o . ?acl ?p ?o } }

825

where {

826

graph ?repo {

827

{ ?view ?p ?o }

828

union

829

{ ?acl <http://www.w3.org/ns/auth/acl#accessTo> ?view .

830

?acl ?p ?o } } }")

831

832

833

(defgeneric authorized-repository-view (repository view agent &key operation)

834

(:method ((repository t) (view-name t) (agent t) &key operation)

835

(declare (ignore operation))

836

nil)

837

(:method ((repository repository) (view-name string) (agent agent) &key (operation |acl|:|Execute|))

838

(when (plusp (length view-name))

839

(let ((view (make-view :repository repository :name view-name)))

840

(cond ((read-view-definition view)

841

(if (or (access-authorized-p view agent operation)

842

(equalp "builtin" (view-summary view)))

843

(view-query view)

844

(spocq.e:authorization-error :operation operation

845

                                                 :location (spocq.i::view-identifier view)

846

:agent agent)))

847

(t

848

nil))))))

849

850

(defgeneric repository-view (repository view)

851

(:method ((repository repository) (view-name string))

852

(let ((view (make-view :repository repository :name view-name)))

853

(when (read-view-definition view)

854

(view-query view))))

855

(:method ((repository-id string) (view-name string))

856

(repository-view (repository repository-id) view-name)))

857

858

(defgeneric repository-view-definition (repository view)

859

(:method ((repository repository) (view-name string))

860

(let ((view (make-view :repository repository :name view-name)))

861

(read-view-definition view)))

862

(:method ((repository-id string) (view-name string))

863

(repository-view-definition (repository repository-id) view-name)))

864

865

(defgeneric repository-view-definitions (repository)

866

(:method ((repository repository))

867

(read-repository-view-definitions repository))

868

(:method ((repository-id string))

869

(repository-view-definitions (repository repository-id))))

870

871

872

873

;;; (repository-view (repository "james/test") "all11")

874

 ;;; (cl-ppcre:regex-replace-all #.(cl-ppcre:create-scanner "\\\\n") "asdf\\nqwer" #.(make-string 1 :initial-element #\newline))

875

876

(defgeneric read-view-rdf-properties (view)

877

(:method ((view view))

878

(let* ((uri (view-identifier view))

879

(repository-uri (repository-identifier (view-repository view)))

880

(view-definition

881

(run-sparql-internal

882

`(spocq.a:|project|

883

(spocq.a:|graph| ,repository-uri

884

(spocq.a:|bgp|

885

886

                                 (spocq.a:|triple| ,uri <http://spinrdf.org/sp#text> ?::text)

887

(spocq.a:|triple| ,uri |dc|:|title| ?::title)))

888

(?::name ?::title ?::text))

889

:repository-id (spocq.i::make-repository-id

890

                              :account-name (spocq.i::repository-account-name (spocq.i::view-repository view))

891

:repository-name "system"))))

892

(when view-definition

893

(destructuring-bind ((name title text)) view-definition

894

`(:name ,name :title ,title :text ,text))))))

895

896

(defgeneric gc-views (account)

897

(:method ((eql t))

898

     (loop for ((account)) in (run-sparql-internal "select ?name where { ?account a <urn:dydra:account> . ?account <http://xmlns.com/foaf/0.1/accountName> ?name }"

899

                                                   :repository-id "system/system"

900

                                                   :agent (system-agent))

901

do (gc-views account)))

902

(:method ((account-name string))

903

(loop for (view-identifier view-name)

904

in (run-sparql-internal

905

`(spocq.a:|select|

906

(spocq.a:|graph| ?::|repository|

907

(spocq.a:|bgp|

908

(spocq.a:|triple|

909

?::|view|

910

                                                |http://www.w3.org/1999/02/22-rdf-syntax-ns#|:|type|

911

|urn:dydra|:|View|)

912

(spocq.a:|triple|

913

?::|view|

914

                                                |http://xmlns.com/foaf/0.1/|:|name|

915

?::|name|)))

916

(?::|view| ?::|name|))

917

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

918

:agent (system-agent))

919

for iri-namestring = (iri-lexical-form view-identifier)

920

for repository-name = (fourth (split-string iri-namestring "/"))

921

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

922

for *agent* = (system-agent)

923

       do (cond ((read-sql-query :repository-name repository-name :account-name account-name :name view-name)

924

(format *trace-output* "~&~a exists" view-identifier))

925

(t

926

                 (delete-view-definition (make-instance 'view :repository repository :name view-name) t)

927

(format *trace-output* "~&~a deleted" view-identifier))))))

928

929

;;; (gc-views "james")

930

#+(or)

931

(

932

;;(clsql:locally-enable-sql-reader-syntax)

933

934

(with-sql-query-database-transaction (db)

935

(clsql:list-tables :database db))

936

(with-sql-query-database-transaction (db)

937

(clsql:list-attributes "queries" :database db))

938

(with-sql-query-database-transaction (db)

939

(clsql:list-attribute-types "queries" :database db))

940

941

(with-sql-query-database-transaction (db)

942

(last (clsql:select 'sql-query :database db :where "id = 3451")))

943

(with-sql-query-database-transaction (db)

944

(clsql:select 'sql-query :database db :where "repository_id = 23"))

945

)