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

Kind	Covered	All	%
expression	294	1248	23.6
branch	38	150	25.3

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: org.datagraph.spocq.implementation; -*-

2

3

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

4

5

(:documentation "This file defines authorization operators for the 'org.datagraph.spocq' RDF engine."

6

7

(copyright

8

9

10

(long-description

11

"Implement authorization determinations for user/account/repository access based on acl assertions

12

stored in an account's system repository. The schema follows the w3c proposal[1], but includes also

13

negative assertions - that is noAccessTo in addition to accessTo

14

15

The pertinent resource authorizations are

16

/accounts/:account : control - for repository creation and deletion

17

/accounts/:account/authorization : read, write

18

/accounts/:account/configuration : read, write

19

/accounts/:account/configuration/:property : read, write

20

/accounts/:account/profile : read, write

21

/:account/:repository : read, write - for data access

22

/accounts/:account/repositories/:repository/authorization : read, write

23

/accounts/:account/repositories/:repository/configuration : read, write

24

/accounts/:account/repositories/:repository/configuration/:property : read, write

25

/accounts/:account/repositories/:repository/profile : read, write

26

27

But for the :repository/configuration -- :repository/configuration/:property combination,

28

each is a distinct resource.

29

The distinction between the resource which holds the authorization information and

30

the target is implemented by delegating to the resource-instance for the authorization list,

31

while permitting the resource to specify the pertinent resource-identifier for the access target

32

to be tested with respect to the authorizations.

33

34

  authorization combines with scripts to add options to control access to the request and response streams.

35

  for example, requests from an account could remote access to the request content and limit the source for

36

queries to a specific view url or a specific repository.

37

---

38

[1] : http://www.w3.org/wiki/WebAccessControl

39

"))

40

41

42

(defun system-agent ()

43

(or *system-agent*

44

(setq *system-agent* (make-instance 'administrator :name "system" :location "127.0.0.1"))))

45

46

(defgeneric task-access-mode (task)

47

#+(or)

48

(:method ((task task))

49

(if (operation-read-only-p task) |acl|:|Read| |acl|:|Write|))

50

(:method ((task task))

51

(task-operation-access-mode task (task-operation task))))

52

53

(defgeneric task-operation-access-mode (task operation)

54

(:method ((task query) (operation symbol))

55

(if (member operation '(update nil) :test #'string-equal)

56

|acl|:|Write| |acl|:|Read|)))

57

58

59

(defgeneric api-authorized-p (authorized-mode operation-mode)

60

(:method ((authorized t) (operation t))

61

(log-warn "api-authorized-p: invalid combination: ~s ~s" authorized operation)

62

nil)

63

(:method ((authorized list) (operation t))

64

(loop for mode in authorized

65

when (api-authorized-p mode operation)

66

return t))

67

68

(:method ((authorized (eql :control)) (operation t))

69

(api-authorized-p |http://www.w3.org/ns/auth/acl#|:|Control| operation))

70

(:method ((authorized (eql :write)) (operation t))

71

(api-authorized-p |http://www.w3.org/ns/auth/acl#|:|Write| operation))

72

(:method ((authorized (eql :read)) (operation t))

73

(api-authorized-p |http://www.w3.org/ns/auth/acl#|:|Read| operation))

74

(:method ((authorized (eql :read-write)) (operation t))

75

(api-authorized-p '(|http://www.w3.org/ns/auth/acl#|:|Write|

76

|http://www.w3.org/ns/auth/acl#|:|Read|)

77

operation))

78

(:method ((authorized (eql :read-write-control)) (operation t))

79

(api-authorized-p '(|http://www.w3.org/ns/auth/acl#|:|Write|

80

|http://www.w3.org/ns/auth/acl#|:|Read|

81

|http://www.w3.org/ns/auth/acl#|:|Control|)

82

operation))

83

84

(:method ((authorized t) (operation (eql :write)))

85

(api-authorized-p authorized |http://www.w3.org/ns/auth/acl#|:|Write|))

86

(:method (authorized (operation (eql :read)))

87

(api-authorized-p authorized |http://www.w3.org/ns/auth/acl#|:|Read|))

88

89

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Read|))

90

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Read|)))

91

t)

92

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Read|))

93

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Write|)))

94

nil)

95

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Read|))

96

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Control|)))

97

nil)

98

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Write|))

99

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Read|)))

100

nil)

101

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Write|))

102

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Control|)))

103

nil)

104

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Write|))

105

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Write|)))

106

t)

107

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Control|))

108

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Control|)))

109

t)

110

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Control|))

111

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Read|)))

112

nil)

113

(:method ((authorized (eql |http://www.w3.org/ns/auth/acl#|:|Control|))

114

(operation (eql |http://www.w3.org/ns/auth/acl#|:|Write|)))

115

nil))

116

117

(defgeneric identifier-in-realm-p (resource-identifier realm-identifier)

118

(:method ((id1 null) (id2 t))

119

nil)

120

(:method ((id1 t) (id2 null))

121

nil)

122

(:method ((id1 null) (id2 null))

123

nil)

124

   ;; nb. no support for target lists as, since the acl is sorted, each entry must have a single target

125

(:method ((resource-identifier spocq:iri) (realm-identifier t))

126

(identifier-in-realm-p (spocq:iri-lexical-form resource-identifier) realm-identifier))

127

(:method ((resource-identifier t) (realm-identifier spocq:iri))

128

(identifier-in-realm-p resource-identifier (spocq:iri-lexical-form realm-identifier)))

129

130

(:method ((resource-identifier string) (realm-identifier string))

131

(log-debug "identifier-in-realm-p: ~s ~s" resource-identifier realm-identifier)

132

(and (<= (length realm-identifier) (length resource-identifier))

133

(string= realm-identifier resource-identifier :end2 (length realm-identifier))))

134

135

(:method ((resource identified-object) (realm t))

136

(identifier-in-realm-p (capability-identifier resource) realm)))

137

138

(defun compare-authorization-realms (one other)

139

(cond ((equalp one other)

140

0)

141

((identifier-in-realm-p one other)

142

-1)

143

(t ;; (identifier-in-realm-p other one)

144

1)))

145

146

(defgeneric compare-authorization-agent-ids (one other)

147

(:documentation "return -/0/+ depending on whether the first argument agent id is in the realm of

148

the second, or the relation is inverted.")

149

(:method ((one agent) (other t))

150

(compare-authorization-agent-ids (agent-identifier one) other))

151

(:method ((one t) (other agent))

152

(compare-authorization-agent-ids one (agent-identifier other)))

153

(:method ((one authorization) (other t))

154

(compare-authorization-agent-ids (authorization-agent-id one) other))

155

(:method ((one t) (other authorization))

156

(compare-authorization-agent-ids one (authorization-agent-id other)))

157

158

(:method ((one t) (other t))

159

(cond ((equalp one other)

160

0)

161

((identifier-in-realm-p one other)

162

-1)

163

((identifier-in-realm-p other one)

164

1))))

165

166

(defgeneric compare-authorization-modes (one other)

167

(:method ((one list) (other list))

168

(loop for one in one

169

do (ecase (compare-authorization-modes one other)

170

((-1 0) (setf other (remove one other)))

171

(1 (return 1)))

172

finally (return (if (null other) 0 -1))))

173

(:method ((one symbol) (other list))

174

(if (find one other)

175

(if (rest other) -1 0)

176

1))

177

(:method ((one symbol) (other null))

178

1)

179

(:method ((one symbol) (other symbol))

180

(if (eq one other) 0 1)))

181

182

(and (eql 0 (compare-authorization-modes '(|acl|:|Read| |acl|:|Write|) '(|acl|:|Read| |acl|:|Write|)))

183

(eql -1 (compare-authorization-modes '(|acl|:|Read| ) '(|acl|:|Read| |acl|:|Write|)))

184

(eql 1 (compare-authorization-modes '(|acl|:|Read| |acl|:|Write|) '(|acl|:|Read| ))))

185

186

187

(defgeneric url-authorization-url (target)

188

(:method ((target t)) ;; interned iri -> symbols

189

target)

190

(:method ((target spocq:http-url))

191

(let* ((lexical-form (spocq:url-lexical-form target))

192

(type (when lexical-form (http:resource-path-type lexical-form))))

193

(if type

194

(intern-iri (subseq lexical-form 0 (- (length lexical-form) (1+ (length type)))))

195

target))))

196

197

(defparameter *access-authorized-p.cache-false* nil)

198

199

;;; allow federation

200

 #+(or) (defmethod ACCESS-AUTHORIZED-P ((repository service-repository) (agent rdfcache-account) (mode (eql |http://www.w3.org/ns/auth/acl#|:|Read|))) t)

201

(defgeneric access-authorized-p (target agent action)

202

(:documentation

203

"Iff the agent is authorized to perform the action on the target, return true.

204

205

The control flow involves two levels:

206

- an outer level handles cached capability lists per agent

207

- a second level resolves targets to identifiers

208

      - the base level extracts the (target x agent x mode) authorization relation from the acl graph.

209

210

Logic to cache the results for an individual (target x agent x mode) combination

211

resolves the target to the iri lexical form

212

213

The method for administrators supersedes everything to permit universal access.")

214

215

(:argument-precedence-order agent target action)

216

217

(:method :around ((target t) (agent administrator) (action t))

218

"Override all other evaluation to indicate access is allowed"

219

action)

220

221

(:method :around ((target authorized-resource) (agent agent) (action t))

222

"Check for and reuse the status for a known agent respective the resource.

223

Iff none exists, compute and cache it."

224

;;(format *error-output* "~%~a" (hunchentoot::get-backtrace))

225

(let* ((target-namestring (iri-lexical-form (capability-identifier target)))

226

(capability (cons target-namestring action)))

227

(multiple-value-bind (determination known-p)

228

(agent-capability agent capability)

229

;; check for a known determination for the agent-action combination

230

(cond (known-p

231

determination)

232

(t

233

;; if none is known, derive and cache the specific result

234

(setf determination (call-next-method))

235

(when (or determination *access-authorized-p.cache-false*)

236

(setf (agent-capability agent capability) determination))

237

                (log-debug "access-authorized-p: newly cached ~s ~s ~s ~s" agent determination action target)))

238

(log-notice "access-authorized-p: ~s ~s ~s ~s" agent determination action target)

239

determination)))

240

241

(:method ((target account) (agent agent) (action t))

242

(or (eql (agent-account agent) target)

243

(not (control-account-access target))

244

(query-capability (instance-repository-id target) agent target action)))

245

246

(:method ((target repository) (agent agent) (action t))

247

(or (eql (agent-account agent) (repository-account target))

248

(not (control-repository-access (repository-account target)))

249

(query-capability (instance-repository-id target) agent target action)))

250

251

(:method ((target view) (agent agent) (action t))

252

(or (eql (agent-account agent) (view-account target))

253

(not (control-view-access (view-account target)))

254

(query-capability (instance-repository-id (view-repository target)) agent target action)))

255

256

(:method ((target spocq:url) (agent agent) (action t))

257

     "given an arbitrary resource identifier, attempt to locate its metadata from the the authorization:"

258

(let* ((path (split-string (puri:uri-path (puri:uri target)) "/"))

259

(account-name (first path))

260

(repository-name (second path))

261

(authorization-target (url-authorization-url target))

262

(determination

263

(cond ((equal (agent-name agent) account-name))

264

((account-exists-p account-name)

265

(let ((account (account account-name)))

266

(or (eql (agent-account agent) account)

267

                          (query-capability (instance-repository-id account) agent authorization-target action

268

:account account

269

                                            :repository-id (compute-repository-identifier account-name repository-name))

270

)))

271

(t

272

(query-capability (system-repository) agent authorization-target action)

273

))))

274

(log-notice "access-authorized-p: ~s ~s ~s ~s" agent determination action target)

275

determination))

276

277

(:method ((target repository) (agent account) (action t))

278

(or (not (control-repository-access (repository-account target)))

279

(query-capability (instance-repository-id target) agent target action)))

280

281

(:method ((target repository) (agent view) (action t))

282

(or (not (control-repository-access (repository-account target)))

283

(query-capability (instance-repository-id target) agent target action)))

284

285

;; the default method denies access

286

(:method ((target t) (agent t) (action t))

287

nil))

288

289

(defgeneric access-authorization-authorizes-p (authorization resource agent action)

290

   (:documentation "Used by access-authorized-p to test the requested mode against an authorization entry .")

291

(:method ((context t) (target t) (agent t) (action t))

292

nil)

293

(:method ((authorization authorization) (target authorized-resource) (agent agent) (action t))

294

"this, the base method for authorizations, tests that the action is specified."

295

(find action (authorization-access-mode authorization)))

296

297

(:method ((authorization anonymous-authorization) (target authorized-resource) (agent null) (action t))

298

(find action (authorization-access-mode authorization)))

299

300

(:method ((authorization location-authorization) (target authorized-resource) (agent agent) (action t))

301

(and (loop with location = (agent-location agent)

302

for predicate in (authorization-location-predicates authorization)

303

when (funcall predicate location)

304

return t)

305

(call-next-method)))

306

307

   (:method ((authorization authenticated-authorization) (target authorized-resource) (account account) (action t))

308

(agent-equal-p account (authorization-agent-id authorization)))

309

310

   (:method ((authorization authenticated-authorization) (target authorized-resource) (agent agent) (action t))

311

"When authentication is required, if an id is specified, it must match.

312

Otherwise, permit a match by class."

313

(let ((authorization-agent-id (authorization-agent-id authorization)))

314

;; first, check if the agent matches

315

(and (case authorization-agent-id

316

((nil |urn:dydra|:|User|)

317

(case (authorization-agent-class authorization)

318

(|urn:dydra|:|LocatedAgent|

319

(agent-location agent))

320

((|urn:dydra|:|User| |urn:dydra|:|Account|)

321

(agent-identifier agent))))

322

(|http://xmlns.com/foaf/0.1/|:|Agent| ; anomalous

323

t)

324

(t

325

(progn

326

                 (log-debug "access-authorized-p: test agent: ~s ~s " (agent-identifier agent) authorization-agent-id)

327

(agent-equal-p agent authorization-agent-id))))

328

(progn

329

(log-debug "access-authorized-p: agent matched ~s " agent)

330

t)

331

;; continue, to test the action

332

(call-next-method)))))

333

334

335

(defgeneric anonymous-authorization-p (object)

336

(:method ((object t)) nil)

337

(:method ((object anonymous-authorization)) t)

338

(:method ((authorization-list authorization-list))

339

(some #'anonymous-authorization-p (authorization-list-controls authorization-list))))

340

341

(defgeneric anonymous-access-authorized-p (target)

342

(:documentation "Return true iff anonymous access is, in general permitted,

343

that is, without the an agent and without respect to the action.")

344

(:method ((authorization-list authorization-list))

345

(some #'anonymous-authorization-p (authorization-list-controls authorization-list)))

346

(:method ((target authorized-resource))

347

(let ((acl-list (resource-authorization-list target)))

348

(when acl-list (anonymous-access-authorized-p acl-list)))))

349

350

351

352

(defgeneric resource-authorization-list (resource)

353

(:method ((resource authorized-resource))

354

(or (get-resource-authorization-list resource)

355

(let ((*agent* (system-agent)))

356

           (setf-resource-authorization-list (read-resource (make-resource-authorization-list resource)) resource)))))

357

358

(defgeneric make-resource-authorization-list (resource &rest args)

359

(:method ((resource authorized-resource) &rest args)

360

(declare (dynamic-extent args))

361

(apply #'make-instance 'authorization-list

362

:resource resource

363

args)))

364

365

366

(defgeneric combine-resource-authorization-lists (base restrictions)

367

(:method :around ((l1 t) (l2 t))

368

(if (eq l1 l2)

369

l1

370

(call-next-method)))

371

(:method ((base list) (restrictions list))

372

(flet ((more-restrictive (restriction)

373

(loop for base-authorization in base

374

when (authorization-less-p restriction base-authorization)

375

return t)))

376

(declare (dynamic-extent #'more-restrictive))

377

(append (remove-if-not #'more-restrictive restrictions) base)))

378

(:method ((base authorization-list) (restrictions t))

379

(combine-resource-authorization-lists (authorization-list-controls base) restrictions))

380

(:method ((base t) (restrictions authorization-list))

381

(combine-resource-authorization-lists base (authorization-list-controls restrictions))))

382

383

;;; (compute-resource-authorization-list "james/test")

384

385

386

(defgeneric authorization-less-p (one-authorization other-authorization)

387

(:documentation "return true iff the one autorization applies to a proper subset of agents

388

and allows a proper subset of privileges compared to the other.")

389

(:method ((one authorization) (other authorization))

390

(flet ((compare-realms (r1 r2)

391

(if (and r1 r2)

392

(compare-authorization-realms r1 r2)

393

0)))

394

(let ((to-one (authorization-access-to one))

395

(to-other (authorization-access-to other))

396

(not-to-one (authorization-no-access-to one))

397

(not-to-other (authorization-no-access-to other)))

398

(or (and not-to-one to-other (ecase (compare-realms not-to-one to-other)

399

((-1 0) t) ((1 nil) nil)))

400

(and (ecase (compare-realms to-one to-other)

401

((-1 0) t) ((1 nil) nil))

402

(ecase (compare-realms not-to-one not-to-other)

403

((-1 0) t) ((1 nil) nil))

404

(ecase (compare-authorization-agent-ids one other)

405

((-1 0) t) ((1 nil) nil))

406

                  (ecase (compare-authorization-modes (authorization-access-mode one) (authorization-access-mode other))

407

((-1 0) t) ((1 nil) nil))))))))

408

409

410

411

(defmethod encode-presentation-graph ((authorization-list authorization-list))

412

;;; convert(c s p o) to (s p o)

413

(mapcar #'rest (authorization-list-statements authorization-list)))

414

415

416

 (defmethod decode-presentation-graph ((authorization-list authorization-list) (state (eql |urn:dydra|:|default|)))

417

"Recognize the 'default' keyword to reset the authorization list to just minimal

418

access for the owner."

419

(setf (authorization-list-statements authorization-list)

420

(loop for (nil s p o c)

421

               in (compute-initial-resource-authorization-graph (authorization-list-resource authorization-list))

422

collect (list c s p o)))

423

authorization-list)

424

425

(defmethod decode-presentation-graph ((authorization-list authorization-list) (state cons))

426

(let* ((identifier (instance-identifier authorization-list))

427

(agent-ids ())

428

(cspo-statements (loop for statement in state

429

for (s p o) = statement

430

when (member p '(|urn:dydra|:|User|))

431

do (push o agent-ids)

432

collect (cons identifier statement))))

433

#+(or) ; do not constraint the agent ids

434

(with-open-transaction (*system-repository-id*)

435

(let ((unknown-agents (loop for id in agent-ids

436

                                   unless (repository-match-field *transaction* |urn:dydra|:|default| id '?::p '?::o)

437

collect id)))

438

(assert (null unknown-agents) ()

439

"Agents are not known: ~{~s~^, ~}" unknown-agents)))

440

(setf (authorization-list-statements authorization-list) cspo-statements)

441

authorization-list))

442

443

(defmethod decode-presentation-graph ((authorization-list authorization-list) (state t))

444

(error 'type-error :datum state :expected-type '(or cons (eql |urn:dydra|:|default|))))

445

446

447

(defmethod unbind-resource ((resource authorization-list))

448

(setf-authorization-list-statements nil resource)

449

(setf (authorization-list-controls resource) nil)

450

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

451

resource)

452

453

(defmethod encode-store-graph ((authorization-list authorization-list))

454

;; use the cached statements directly

455

(authorization-list-statements authorization-list))

456

457

(defmethod decode-store-graph ((authorization-list authorization-list) (acl-statements list))

458

;; decode the graph and cache it for round-trips

459

(setf (authorization-list-statements authorization-list) acl-statements)

460

(setf-instance-store-graph acl-statements authorization-list)

461

authorization-list)

462

463

464

;;;

465

;;; coordinate statements and authorization controls

466

467

(defmethod (setf authorization-list-statements) ((statements list) (authorization-list authorization-list))

468

(setf-authorization-list-statements statements authorization-list)

469

(setf (authorization-list-controls authorization-list)

470

(compute-graph-authorization-controls statements authorization-list)))

471

472

473

;;;

474

;;; graph <-> authorizations

475

476

#+(or)

477

(defmethod decode-json-object ((object authorization-list) (json-data t) &rest args)

478

"Decode the json data as autorizations - either a list of or a single one.

479

Provide the slots definitions for the concrete authorization classes as the

480

specifications"

481

(declare (dynamic-extent args))

482

(apply #'decode-json-object (instance-predicates object) json-data args))

483

484

485

;;; (identifier-in-realm-p <http://dydra.com/account/configuration> <http://dydra.com/account>)

486

;;; (identifier-in-realm-p <http://dydra.com/account> <http://dydra.com/account/configuration>)

487

488

(defgeneric compute-graph-authorization-controls (graph authorization-list)

489

(:documentation "Extract the resource's authorization-relevant metadata and

490

translate it into authorization controls.")

491

492

(:method ((statements list) (authorization-list authorization-list))

493

;; given the specification as a (c s p o) field

494

;; compute the declared authentication controls using all assertions

495

;; which include the identified resource as the accessTo target

496

;; this allows to construct the list form a cbd in which the resource may

497

;; appear as an agent as well as the target.

498

(let* ((cache (make-hash-table :test 'eq))

499

(identifier (instance-identifier authorization-list)))

500

(loop for (nil subject predicate object) in statements

501

do (case predicate

502

(|acl|:|accessTo| ; allow multiples

503

(push object (getf (gethash subject cache) :access-to)))

504

(|acl|:|noAccessTo| ; allow multiples

505

(push object (getf (gethash subject cache) :no-access-to)))

506

(|acl|:|agent|

507

(setf (getf (gethash subject cache) :agent-id) object)

508

(setf (getf (gethash subject cache) :agent-class) |urn:dydra|:|User|))

509

(|acl|:|agentClass|

510

(setf (getf (gethash subject cache) :agent-class) object)

511

#+(or)

512

(if (iri-p object)

513

(setf (getf (gethash subject cache) :agent-class) object)

514

(let ((class (some #'(lambda (stmt)

515

                                            (when (and (eq (second stmt) object) (eq (third stmt) |rdf|:|type|))

516

(fourth stmt)))

517

statements))

518

(locations (mapcar #'fourth

519

                                              (remove-if-not #'(lambda (stmt)

520

                                                                 (and (eq (second stmt) object)

521

                                                                      (eq (third stmt) |sioc|:|ip_address|)))

522

                                                             statements))))

523

(setf (getf (gethash subject cache) :agent-class) class)

524

(setf (getf (gethash subject cache) :locations) locations))))

525

(|sioc|:|ip_address|

526

(push object (getf (gethash subject cache) :locations)))

527

((|acl|:|mode|)

528

(push object (getf (gethash subject cache) :access-mode)))

529

(t ; skip everything else

530

)))

531

(sort (loop for initargs being each hash-value of cache

532

for target-resource-ids = (getf initargs :access-to)

533

for target-resource-ids-not = (getf initargs :no-access-to)

534

for class = (if (getf initargs :agent-id)

535

(if (getf initargs :locations)

536

'authenticated-location-authorization

537

'authenticated-authorization)

538

(case (getf initargs :agent-class)

539

((nil |foaf|:|Agent|)

540

(if (getf initargs :locations)

541

'anonymous-location-authorization

542

'anonymous-authorization))

543

(t

544

(if (getf initargs :locations)

545

'authenticated-location-authorization

546

'authenticated-authorization))))

547

if (or target-resource-ids target-resource-ids-not)

548

append (loop for access-to in target-resource-ids

549

if (and (eq class 'anonymous-authorization)

550

                                      (not (equal (getf initargs :access-mode) '(|http://www.w3.org/ns/auth/acl#|:|Read|))))

551

                              do (log-warn "excessive anonymous access: ~s . ~s" access-to initargs)

552

                              else collect (apply #'make-instance class :access-to access-to initargs)

553

554

)

555

and append (loop for no-access-to in target-resource-ids-not

556

                                      collect (apply #'make-instance class :no-access-to no-access-to initargs))

557

                     else do (log-warn "Anomalous authorization for resource: ~s, ~s" identifier initargs))

558

#'>

559

               :key #'(lambda (authorization) (length (spocq:iri-lexical-form (or (authorization-access-to authorization)

560

                                                                                  (authorization-no-access-to authorization)))))))))

561

562

(defgeneric compute-initial-resource-authorization-graph (resource)

563

(:method ((account account))

564

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

565

566

(:method ((repository repository))

567

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

568

569

;;;

570

;;; authentication

571

572

;;; by token

573

574

(defgeneric agent-authenticated-by-token (token &key if-does-not-exist location repository)

575

(:documentation "Given a token, if the agent is known, return the cached instance.

576

Otherwise, look of the agent identity from the persistent account information.

577

If it is known, instantiate and return the corrsponding agent.

578

If not, return nil or signal an error as specified by :if-does-not-exit")

579

580

(:method ((token string) &key (if-does-not-exist :error) (location nil)

581

(repository (system-repository)))

582

(or (gethash (list :token token) *users*)

583

(unless (or (null-sequence-p token) (null-sequence-p *system-repository-id*))

584

(multiple-value-bind (user-id admin-p user-name account-name)

585

(authenticate-user-token repository token)

586

(when user-id

587

(ensure-agent

588

:name user-name

589

:identifier user-id

590

:location location

591

:token token

592

:account account-name

593

:admin-p admin-p))))

594

(ecase if-does-not-exist

595

((nil) nil)

596

(:error

597

(error "Unknown token '~c...~c'" (char token 0) (char token (1- (length token))))))))

598

599

(:method ((token t) &key (if-does-not-exist :error) &allow-other-keys)

600

(ecase if-does-not-exist

601

((nil) nil)

602

(:error

603

(error "Invalid token '~s'" token)))))

604

#+(or)

605

(progn

606

(spocq:unbound-variable-p (SPOCQ:make-UNBOUND-VARIABLE NIL))

607

(room t)

608

(dotimes (x 1000)

609

(clrhash *users*)

610

(agent-authenticated-by-token "sXQeb11KcCyoX6n9n90X" :if-does-not-exist nil))

611

(sb-ext:gc :full t)

612

(room t))

613

614

615

 ;;; could rewrite this to cross (match ?account accessToken ,auth-token)  with (match ,account ?prop ?value)

616

;;; and do the join by hand...

617

618

 ;;; (defmethod spocq.si::authenticate-user-token :before (repository auth-token) ) ;; (print spocq.i::*agent*))

619

620

(defparameter *authenticate-user-token.sparql*

621

'(spocq.a:|select|

622

(spocq.a:|leftjoin|

623

(spocq.a:|leftjoin|

624

(spocq.a:|leftjoin|

625

626

(spocq.a:|bgp|

627

                                                          (spocq.a:|triple| ?::user |urn:dydra|:|accessToken| ?::auth-token)

628

                                                          (spocq.a:|triple| ?::user |dc|:|title| ?::name)))

629

630

(spocq.a:|bgp|

631

                                                          (spocq.a:|triple| ?::user |sioc|:|administrator_of|  ?::isAdminOf))))

632

(spocq.a:|join|

633

634

(spocq.a:|bgp|

635

                                                          (spocq.a:|triple| ?::accountByOwner |acl|:|owner| ?::user)))

636

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

637

(spocq.a:|bgp|

638

                                                          (spocq.a:|triple| ?::accountByOwner |foaf|:|accountName| ?::accountNameByOwner)))))

639

(spocq.a:|join|

640

641

(spocq.a:|bgp|

642

                                                 (spocq.a:|triple| ?::accountbyToken |urn:dydra|:|accessToken| ?::auth-token)))

643

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

644

(spocq.a:|bgp|

645

                                                 (spocq.a:|triple| ?::accountbyToken |foaf|:|accountName| ?::accountNameByToken)))))

646

(?::user ?::isAdminOf ?::name ?::auth-token ?::accountNameByOwner ?::accountNameByToken))

647

   "Locate user restricted by token, with addition information on the owned and any restricted account")

648

649

650

651

(defparameter *authenticate-user-token.query* nil)

652

(defun compute-authenticate-user-token-query (&rest args &key (id (make-internal-task-id) )

653

                                                     (agent (system-agent))

654

                                                     &allow-other-keys)

655

(unless *authenticate-user-token.query*

656

(setq *authenticate-user-token.query*

657

(make-query

658

:id id

659

:sse-expression *authenticate-user-token.sparql*

660

:account (account "system")

661

:repository-id *system-repository-id*

662

:agent agent

663

:dynamic-bindings `((?::auth-token) ,"")) ; as a place holder

664

)

665

(with-task-environment (:task *authenticate-user-token.query*)

666

(compile-query *authenticate-user-token.query*)))

667

(apply #'clone-instance *authenticate-user-token.query* :id id

668

:agent agent

669

args))

670

671

#+(or)

672

(defun run-authenticate-user-token-query (&rest args)

673

(let ((cl-user::*map-repository-statements-callback.verbose* t)

674

(*DATA-TRACE-OUTPUT* *trace-output*)

675

(*ALGEBRA-TRACE-OUTPUT* *trace-output*))

676

(apply #'run-sparql-internal *authenticate-user-token.sparql* args)))

677

(defun run-authenticate-user-token-query (&rest args)

678

(apply #'run-sparql-internal *authenticate-user-token.sparql* args))

679

(defun rerun-authenticate-user-token-query (&rest args)

680

(apply #'run-sparql-internal *authenticate-user-token.sparql* args))

681

#|

682

(in-package :spocq.i)

683

(initialize-spocq)

684

(loop for i below 1000

685

do (multiple-value-bind (id admin? user account)

686

(authenticate-user-token (system-repository) "sXQeb11KcCyoX6n9n90X")

687

(unless (and (stringp user) (stringp account))

688

(break "query failed: ~s" (list id admin? user account)))))

689

|#

690

691

(defparameter cl-user::*map-repository-statements-callback.verbose* nil)

692

693

(defgeneric authenticate-user-token (repository auth-token &key location)

694

(:method ((repository t) (auth-token t) &key location)

695

(declare (ignore location))

696

nil)

697

(:method ((repository-id string) (auth-token t) &rest args)

698

(declare (dynamic-extent args))

699

(apply #'authenticate-user-token (repository repository-id) auth-token args))

700

701

(:method ((repository repository) (auth-token string) &key location)

702

(declare (ignore location)) ; should eventually use that as an added contraint

703

;; nb. the method with a pre-compiled query fails unless it is cloned, which

704

;; eliminates much advantage, while adding complexity

705

(let ((results (run-authenticate-user-token-query :repository repository

706

                                                       :agent (system-agent)

707

                                                       :dynamic-bindings `((?::auth-token) ,auth-token))))

708

(when (consp results)

709

           (destructuring-bind ((user-id is-admin user-name token account-by-owner account-by-token) &rest others) results

710

(when others

711

(log-warn "token authenticates multiple users. : ~s . : ~s"

712

                         (list user-id is-admin user-name token account-by-owner account-by-token)

713

others))

714

(cond ((iri-p user-id)

715

(unless (stringp user-name)

716

                      (log-warn "no name in anomalous user token authentication results: ~s"

717

                                (list user-id is-admin user-name token account-by-owner account-by-token))

718

(let* ((iri-string (iri-lexical-form user-id))

719

(iri-name (first (last (split-string iri-string "/")))))

720

(setf user-name iri-name)))

721

(let ((is-admin-p (not (spocq:unbound-variable-p is-admin))))

722

(values user-id

723

is-admin-p

724

user-name

725

(cond ((stringp account-by-owner) account-by-owner)

726

((stringp account-by-token) account-by-token)

727

(t nil)))))

728

(t

729

                    (log-warn "no user-id in anomalous user token authentication results: ~s"

730

                              (list user-id is-admin user-name token account-by-owner account-by-token))

731

#+(or)

732

(let ((cl-user::*map-repository-statements-callback.verbose* t)

733

(*DATA-TRACE-OUTPUT* *trace-output*)

734

(*ALGEBRA-TRACE-OUTPUT* *trace-output*))

735

(log-warn "anomalous user token authentication results: ~s"

736

                                (list user-id is-admin user-name token account-by-owner account-by-token))

737

738

(log-warn "rerun token authentication results: ~s"

739

                                (rerun-authenticate-user-token-query :repository repository

740

                                                                     :agent (system-agent)

741

                                                                     :dynamic-bindings `((?::auth-token) ,auth-token))))

742

nil)))))))

743

744

;;; (authenticate-user-token "system/system" "sXQeb11KcCyoX6n9n90X")

745

;;; (progn (room t) (dotimes (x 1000) (authenticate-user-token "system/system" "asdf")) (room t))

746

#+(or)

747

(run-sparql-internal "select ?user ?name ?token ?admin

748

where

749

{ { graph <urn:dydra:users>

750

{ ?user <urn:dydra:accessToken> ?token .

751

?user <http://purl.org/dc/elements/1.1/title> ?name } }

752

optional

753

{ graph <urn:dydra:users>

754

{ ?user <http://rdfs.org/sioc/ns#administrator_of> ?admin } }

755

}"

756

:repository-id "system/system"

757

:agent (system-agent))

758

759

(defun account-access-token (account-name &key (if-does-not-exist :error))

760

(let ((alternatives (run-sparql-internal `(spocq.a:|select|

761

(spocq.a:|union|

762

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

763

                                                        (spocq.a:|bgp|

764

                                                         (spocq.a:|triple| ?::account |http://xmlns.com/foaf/0.1/|:|accountName| ,account-name)

765

                                                         (spocq.a:|triple| ?::account |urn:dydra|:|accessToken| ?::|token|)

766

))

767

(spocq.a:|bgp|

768

                                        (spocq.a:|triple| ?::account |http://xmlns.com/foaf/0.1/|:|accountName| ,account-name)

769

                                        (spocq.a:|triple| ?::account |urn:dydra|:|accessToken| ?::|token|)

770

))

771

(?::|token| ?::account))

772

:repository-id *system-repository-id*

773

:agent (system-agent))))

774

(cond (alternatives

775

(when (rest alternatives)

776

;; error. it could yield an uintended user

777

              (error "account-access-token: anomalous results for account ~s: ~s" account-name alternatives))

778

(destructuring-bind (token account) (first alternatives)

779

(values token account)))

780

(t

781

(ecase if-does-not-exist

782

(:error (error "Account not found: ~s." account-name))

783

((nil) nil))))))

784

785

786

(defgeneric describe-token-resource (repository auth-token)

787

(:method ((repository-id string) (auth-token t))

788

(describe-token-resource (repository repository-id) auth-token))

789

(:method ((repository repository) (auth-token string))

790

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

791

(spocq.a:|union|

792

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

793

(spocq.a:|bgp|

794

                                      (spocq.a:|triple| ?::account |urn:dydra|:|accessToken| ,auth-token)

795

                                      (spocq.a:|triple| ?::account ?::predicate ?::object)))

796

(spocq.a:|bgp|

797

798

(spocq.a:|triple| ?::account ?::predicate ?::object)))

799

(?::account ?::predicate ?::object))

800

:repository repository

801

:agent (system-agent))))

802

803

804

;;; by password

805

806

(defparameter *authenticate-user-password.sparql*

807

'(spocq.a:|select|

808

(spocq.a:|leftjoin|

809

(spocq.a:|leftjoin|

810

811

(spocq.a:|bgp|

812

                                                 (spocq.a:|triple| ?::user |urn:dydra|:|encryptedPassword| ?::encrypted)

813

                                                 (spocq.a:|triple| ?::user |dc|:|title| ?::name)))

814

815

(spocq.a:|bgp|

816

                                                 (spocq.a:|triple| ?::account |acl|:|owner| ?::user)

817

                                                 (spocq.a:|triple| ?::account |foaf|:|accountName| ?::accountName))))

818

819

(spocq.a:|bgp|

820

                                        (spocq.a:|triple| ?::user |sioc|:|administrator_of|  ?::isAdminOf))))

821

(?::user ?::isAdminOf ?::encrypted ?::name ?accountName)))

822

823

(defparameter *authenticate-user-password.query* nil)

824

(defun compute-authenticate-user-password-query (&rest args &key (id (make-internal-task-id) )

825

                                                     (agent (system-agent))

826

                                                     &allow-other-keys)

827

"based on

828

829

SELECT ?user ?account ?admin ?encrypted

830

WHERE { graph <urn:dydra:users>

831

{ ?user foaf:accountName 'user-name' .

832

?user <urn:dydra:passwordHash> ?encrypted . }

833

optional

834

{ ?user sioc:administrator_of ?isAdminOf . }

835

}

836

837

with criteria as per http://php.net/manual/en/function.crypt.php"

838

(unless *authenticate-user-password.query*

839

(setq *authenticate-user-password.query*

840

(make-query

841

:sse-expression *authenticate-user-password.sparql*

842

:account (account "system")

843

:repository-id *system-repository-id*

844

:agent agent

845

:dynamic-bindings `((?::name) "")))

846

(with-task-environment (:task *authenticate-user-password.query*)

847

(compile-query *authenticate-user-password.query*)))

848

(apply #'clone-instance *authenticate-user-password.query* :id id :agent agent args))

849

850

 (defparameter +pepper+ "f26f93ae733730c6467f9b3fef6bf3eccf4c410a4b9be82ccc44315d6e143706ee99d6bfdb606fbd7c82aaf6810503ddd547bd13468f0395356df1abc7e17886")

851

852

(defgeneric authenticate-user-password (repository user-name password)

853

(:method ((repository t) (user-name t) (password t))

854

nil)

855

(:method ((repository-id string) (user-name t) (password t))

856

(authenticate-user-password (repository repository-id) user-name password))

857

(:method ((repository repository) (user-name string) (password string))

858

#+use-bcrypt

859

(let ((results (run-sparql-internal *authenticate-user-password.sparql*

860

:repository repository

861

:agent (system-agent)

862

:dynamic-bindings `((?::name) ,user-name))))

863

(when (rest results)

864

;; warn. the password constraint could miss the intended user

865

(log-warn "authenticate-user-password: anomalous results for name ~s: ~s" user-name results))

866

(loop for (user-id is-admin encrypted-pasword name account-name) in results

867

when (and (>= (length encrypted-pasword) 29)

868

(bcrypt:password= (concatenate 'string password +pepper+) encrypted-pasword))

869

return (values user-id

870

(not (spocq:unbound-variable-p is-admin))

871

name

872

(not (spocq:unbound-variable-p account-name)))))))

873

874

(defgeneric agent-authenticated-by-password (user-name password &key if-does-not-exist location)

875

(:documentation "Given a name/password pair, if the agent is known, return the cached instance.

876

Otherwise, look up the agent identity from the persistent account information.

877

If it is known, instantiate and return the corrsponding agent.

878

If not, return nil or signal an error as specified by :if-does-not-exit

879

880

If partial credentials are given, treat the given value as an auth token.

881

Note that 'token:' will likely appear in logs, while ':token' should not.")

882

883

   (:method ((user-name string) (password string) &rest args &key (if-does-not-exist :error) (location nil))

884

(or (if (or (null-sequence-p password) (equalp password "X"))

885

(if (null-sequence-p user-name)

886

nil

887

(apply #'agent-authenticated-by-token user-name args))

888

(if (null-sequence-p user-name)

889

(apply #'agent-authenticated-by-token password args)

890

(unless (null-sequence-p *system-repository-id*)

891

(or (gethash (list :password user-name password) *users*)

892

(multiple-value-bind (user-id admin-p _name_ account-name)

893

                                            (authenticate-user-password (system-repository) user-name password)

894

(declare (ignore _name_))

895

(ensure-agent

896

:name user-name

897

:identifier user-id

898

:location location

899

:password password

900

:account account-name

901

:admin-p admin-p))))))

902

(ecase if-does-not-exist

903

((nil) nil)

904

(:error

905

(error "Unknown user/password '~a'" (unless (equalp password "X") user-name)))))))

906

907

908

;;; by name

909

910

(defparameter *authenticate-user-name.sparql*

911

'(spocq.a:|select|

912

(spocq.a:|leftjoin|

913

(spocq.a:|leftjoin|

914

(spocq.a:|leftjoin|

915

916

(spocq.a:|bgp|

917

                                                          (spocq.a:|triple| ?::user |dc|:|title| ?::name)))

918

919

(spocq.a:|bgp|

920

                                                          (spocq.a:|triple| ?::user |sioc|:|administrator_of|  ?::isAdminOf))))

921

922

(spocq.a:|bgp|

923

                                                 (spocq.a:|triple| ?::user |urn:dydra|:|encryptedPassword| ?::encrypted))))

924

925

(spocq.a:|bgp|

926

                                        (spocq.a:|triple| ?::user |urn:dydra|:|accessToken| ?::auth-token))))

927

(?::user ?::isAdminOf ?::name ?::encrypted ?::auth-token))

928

   "Locate the named user and whether there is either a password or a token associated with them and the admin status.")

929

930

931

(defparameter *authenticate-user-name.query* nil)

932

(defun compute-authenticate-user-name-query (&rest args &key (id (make-internal-task-id) )

933

                                                     (agent (system-agent))

934

                                                     &allow-other-keys)

935

"based on

936

937

SELECT ?user ?account ?admin ?encrypted

938

WHERE { graph <urn:dydra:users>

939

{ ?user foaf:accountName 'user-name' . }

940

optional

941

{ ?user sioc:administrator_of ?isAdminOf . }

942

}

943

"

944

(unless *authenticate-user-name.query*

945

(setq *authenticate-user-name.query*

946

(make-query

947

:sse-expression *authenticate-user-name.query*

948

:account (account "system")

949

:repository-id *system-repository-id*

950

:agent agent

951

:dynamic-bindings `((?::name) "")))

952

(with-task-environment (:task *authenticate-user-name.query*)

953

(compile-query *authenticate-user-name.query*)))

954

(apply #'clone-instance *authenticate-user-name.query* :id id :agent agent args))

955

956

(defparameter *authenticate-user-name.permit-privileges* nil

957

   "allow authentication by name only even if additional auth data is present and/or the user is an admin.")

958

959

(defgeneric authenticate-user-name (repository user-name)

960

(:documentation "provide for the case, where some larger context has done the authentication

961

and it remains just to determine whether the user exists and what privledges the have")

962

(:method ((repository t) (user-name t))

963

nil)

964

(:method ((repository-id string) (user-name t))

965

(authenticate-user-name (repository repository-id) user-name))

966

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

967

#+use-bcrypt

968

(let ((results (run-sparql-internal *authenticate-user-name.sparql*

969

:repository repository

970

:agent (system-agent)

971

:dynamic-bindings `((?::name) ,user-name))))

972

(when (consp results)

973

(when (rest results)

974

;; error. it could yield an uintended user

975

(error "authenticate-user-name: anomalous results for name ~s: ~s" user-name results))

976

(destructuring-bind (user-id is-admin name password token) (first results)

977

(when (or *authenticate-user-name.permit-privileges*

978

(and (spocq:unbound-variable-p is-admin)

979

(spocq:unbound-variable-p password)

980

(spocq:unbound-variable-p token)))

981

(values user-id nil name)))))))

982

983

(defgeneric agent-authenticated-by-name (user-name &key if-does-not-exist location)

984

(:documentation "Given a name, if the agent is known, return the cached instance.

985

Otherwise, look up the agent identity from the persistent account information.

986

If it is known, instantiate and return the corresponding agent.

987

If not, return nil or signal an error as specified by :if-does-not-exit")

988

989

(:method ((user-name string) &key (if-does-not-exist :error) (location nil))

990

(or (gethash (list :name user-name) *users*)

991

(and (not (null-sequence-p user-name))

992

(not (null-sequence-p *system-repository-id*))

993

(multiple-value-bind (user-id admin-p)

994

                                   (authenticate-user-name (system-repository) user-name)

995

(declare (ignore admin-p))

996

(when user-id

997

(ensure-agent ; never admin by name

998

:name user-name

999

:identifier user-id

1000

:location location))))

1001

(ecase if-does-not-exist

1002

((nil) nil)

1003

(:error

1004

(error "Unknown user '~a'" user-name))))))

1005

1006

1007

;;; by session

1008

1009

(defgeneric authenticate-user-session (repository session-id)

1010

(:method ((repository t) (session-id t))

1011

nil)

1012

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

1013

;; 20170915: this version is speculative, as the current storage is in an lmdb database

1014

;; see store;lmdb;spocq.classes.lisp

1015

(let ((results (run-sparql

1016

`(spocq.a:|select|

1017

(spocq.a:|leftjoin|

1018

(spocq.a:|join|

1019

1020

(spocq.a:|bgp|

1021

                                          (spocq.a:|triple| ?::session |urn:dydra|:|session_id| ,session-id)

1022

                                          (spocq.a:|triple| ?::session |urn:dydra|:|session_user| ?::user)))

1023

1024

(spocq.a:|bgp|

1025

                                                        (spocq.a:|triple| ?::user |dc|:|title| ?::name))))

1026

1027

(spocq.a:|bgp|

1028

                                                           (spocq.a:|triple| ?::user |sioc|:|administrator_of|  ?::isAdminOf))))

1029

(?::user ?::isAdminOf ?name))

1030

:repository repository

1031

:agent (system-agent))))

1032

(when (consp results)

1033

(when (rest results)

1034

;; error. it could yield an uintended user

1035

           (error "authenticate-user-session: anomalous results for session ~s: ~s" session-id results))

1036

(destructuring-bind (user-id is-admin user-name) (first results)

1037

(values user-id (not (spocq:unbound-variable-p is-admin)) user-name))))))

1038

1039

1040

(defgeneric agent-authenticated-by-session (session-id &key if-does-not-exist location)

1041

(:documentation "Given a session, if the session is known, return the cached instance.

1042

Otherwise, look for the session and, from that retrieve the user/account information

1043

If it is known, instantiate and return the corresponding agent.

1044

If not, return nil or signal an error as specified by :if-does-not-exit")

1045

1046

(:method ((session-id string) &key (if-does-not-exist :error) (location nil))

1047

(or (gethash (list :session session-id) *users*)

1048

(unless (or (null-sequence-p session-id) (null-sequence-p *system-repository-id*))

1049

(multiple-value-bind (user-id admin-p user-name)

1050

                                (authenticate-user-session (system-repository) session-id)

1051

(when user-id

1052

(ensure-agent

1053

:name user-name

1054

:identifier user-id

1055

:location location

1056

:session session-id

1057

:admin-p admin-p))))

1058

(ecase if-does-not-exist

1059

((nil) nil)

1060

(:error

1061

(error "Unknown session '~a'" session-id))))))

1062

1063

1064

#+(or)

1065

(dydra:sparql-query `(sparql:select (sparql:bgp (?::account |urn:dydra|:|encryptedPassword| ?::pw)

1066

                                          (?::account |acl|:|owner| ?::user))

1067

(?::user ?::pw))

1068

:repository "system/system"

1069

:agent (dydra:system-agent))

1070

1071

;;; nb. this does not include the escaping practice which is pesent in the php code, as the

1072

;;; store operations do not construct and then parse query expressions.

1073

1074

1075

1076

#+(or)

1077

(dydra:sparql-query `(sparql:select (sparql:bgp (?::account |urn:dydra|:|accessToken| ?::token)

1078

                                          (?::account |acl|:|owner| ?::user))

1079

(?::user ?::token))

1080

:repository "system/system"

1081

:agent (dydra:system-agent))

1082

1083

#|

1084

(run-sparql-internal "select ?user ?name ?token ?admin

1085

where

1086

{ { graph <urn:dydra:users>

1087

{ ?user <urn:dydra:accessToken> ?token .

1088

?user <http://purl.org/dc/elements/1.1/title> ?name } }

1089

optional

1090

{ graph <urn:dydra:users>

1091

{ ?user <http://rdfs.org/sioc/ns#administrator_of> ?admin } }

1092

}"

1093

:repository-id "system/system"

1094

:agent (system-agent))

1095

1096

 (authenticate-user-token (repository "system/system") "8v8Wy1ieBVo2JxMhNjnquOq9PUe4QEKLFBlmsTy73NaS6xHGF2EcjCYrozwz")

1097

1098

1099

 (run-sparql-internal "select ?g ?s ?o where { {graph ?g { ?s <http://rdfs.org/sioc/ns#administrator_of> ?o } }

1100

union

1101

                                      { ?s <http://rdfs.org/sioc/ns#administrator_of> ?o } }"

1102

:repository-id "system/system" :agent (system-agent))

1103

(authenticate-user-password "system/system" "james" *password*)

1104

1105

(run-sparql-internal "drop graph <http://dydra.com/accounts/james>"

1106

:repository-id "system/system" :agent (system-agent))

1107

 (run-sparql-internal "insert data { graph <urn:dydra:users> { <http://dydra.com/users/james> <http://rdfs.org/sioc/ns#administrator_of> <http://dydra.com> } }"

1108

:repository-id "system/system" :agent (system-agent) )

1109

1110

 (run-sparql-internal "select ?p where { ?s ?p2 'jhacker' . ?s ?p ?o }" :repository-id "system/system" :agent (system-agent))

1111

(loop for id in '(115632144 869 8779684 981) collect (rlmdb:term-number-value id))

1112

1113

(<http://dydra.com/users/james> <http://rdfs.org/sioc/ns#administrator_of>

1114

<http://dydra.com> |urn:dydra|:|users|)

1115

1116

(loop for id in '(981 115642369 869 8779684) collect (rlmdb:term-number-value id))

1117

1118

(account-access-token "jhacker")

1119

(account-access-token "james")

1120

1121

(defmethod (setf configuration-parameter) :after ((key string) (parameter (eql :api-key)))

1122

(setq *api-key* key))

1123

1124

1125

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

1126

(spocq.a:|bgp|

1127

1128

)

1129

(?::name))

1130

:repository-id "system/system"

1131

:agent (system-agent))

1132

1133

1134

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

1135

(spocq.a:|bgp|

1136

1137

)

1138

(?::|s|))

1139

:repository-id "system/system"

1140

:agent (system-agent))

1141

1142

1143

(let ((authorization-assertions (run-sparql-internal "

1144

select ?node ?mode ?agent ?class

1145

where {

1146

graph ?repositoryURI {

1147

# ?aclNode |acl|:|accessTo| ?repositoryURI .

1148

?aclNode |acl|:|mode| ?mode.

1149

optional { ?aclNode |acl|:|agent| ?agent . }

1150

optional { ?aclNode |acl|:|agentClass| ?classNode .

1151

?classNode |rdf|:|type| ?type .

1152

?classNode ... location, authenticated, user, owner, ...

1153

}"))

1154

(acl-initargs ()))

1155

;; for each node, create one authorization record for each agent/agent-class

1156

;; and accumulate the access mode into it. if it ia an agent class, reify those

1157

;; properties as an agent-class instance

1158

(loop for (node mode agent class) in authorization-assertions

1159

for args = (or (assoc node acl-initargs)

1160

(first (push list node

1161

when agent do (setf (getf (cddr args) :agent) agent)

1162

and when class do (setf (getf (cddr args) :class) class)

1163

)))))

1164

1165

(c2mop:finalize-inheritance (find-class 'authorization-list))

1166

(decode-json-object (allocate-instance (find-class 'authorization-list))

1167

(parse-json "[{\"ID\": \"1\", \"accessTo\": \"a\"},

1168

{\"ID\": \"2\", \"accessTo\": \"b\"}]"))

1169

1170

|#

1171

1172

#+(or)

1173

;;; obsolete; replaced with core authorization logic

1174

(defgeneric get-resource-authorization (repository resource)

1175

(:method ((repository dydra:repository) (resource account-resource))

1176

"given some requested resource, use its _internal_ identifier to collect

1177

the authorization information. this is likely identical with the request-identifier, but

1178

may differ for multi-host sites."

1179

1180

(let* ((id (dydra:instance-identifier resource))

1181

(query `(sparql:select

1182

(sparql:graph ,id

1183

                                   (sparql:leftjoin (sparql:bgp (?::auth |acl|:|accessTo| ,id)

1184

                                                                (?::auth |acl|:|mode| ?::mode))

1185

                                                    (sparql:leftjoin (sparql:bgp (?::auth |acl|:|agent| ?::agent))

1186

                                                                     (sparql:bgp (?::auth |acl|:|agentClass| ?::class)

1187

                                                                                 (?::class |sioc|:|ip_address| ?::ipAddress)))))

1188

(?::auth ?::mode ?::agent ?::ipAddress)))

1189

(results (dydra:sparql-query query :repository repository)))

1190

(when (consp results)

1191

(loop with authorizations = (make-hash-table :test #'equalp)

1192

for (auth-node mode agent ip-address) in results

1193

do (cond (ip-address

1194

                         (setf (getf (gethash auth-node authorizations) :class) 'ip-address-authorization

1195

                               (getf (gethash auth-node authorizations) |sioc|:|ip_address|) ip-address)

1196

                         (push (getf (gethash auth-node authorizations) |acl|:|mode|) mode))

1197

(agent

1198

                         (setf (getf (gethash auth-node authorizations) :class) 'agent-authorization

1199

                               (getf (gethash auth-node authorizations) |acl|:|agent|) agent)

1200

                         (push (getf (gethash ip-address authorizations) |acl|:|mode|) mode)))

1201

finally (return (loop for authorization being each hash-value of authorizations

1202

                                     collect (destructuring-bind (&key class mode ip-address agent) authorization

1203

(declare (ignore class))

1204

(cond (agent

1205

                                                      (make-instance 'agent-authorization :agent agent :mode mode))

1206

(ip-address

1207

                                                      (make-instance 'ip-address-authorization :ip-address ip-address :mode mode)))))))))))

1208

1209

1210

#+(or)

1211

;;; obsolete; replaced with a version without the context as the first argument

1212

(defgeneric access-authorized-p (context target agent action)

1213

(:documentation

1214

"Iff the context permits the agent to perform the action on the target, return true.

1215

1216

The control flow involves three levels:

1217

- the base level evaluate the respective (target agent mode) combination in the

1218

context of an individual authorization control

1219

- a collection level combines the controls in a list according to their +/- status

1220

and the result of the respective individual evaluation

1221

- the application api expects some request object as the context, from which an additional

1222

authorization list may be combined with that from the target.

1223

1224

Logic is included to cache the results for an individual (resource agent) combination -

1225

but independent of context, in order to expedite the determination.

1226

nyi :

1227

- agent class (beyond authenticated, located, anonymous)

1228

- resource class

1229

1230

The method for administrators supersedes everything to permit universal access.")

1231

1232

(:argument-precedence-order agent target context action)

1233

1234

(:method :around ((context t) (target t) (agent administrator) (action t))

1235

"Override all other evaluation to indicate access is allowed"

1236

action)

1237

1238

(:method :around ((context t) (target authorized-resource) (agent agent) (action t))

1239

"Check for and reuse the status for a known agent respective the resource.

1240

Iff none exists, compute and cache it."

1241

1242

(if *authorization-target*

1243

(call-next-method)

1244

(let* ((*authorization-target* target)

1245

(target-namestring (iri-lexical-form (instance-identifier target)))

1246

(capability (cons target-namestring action)))

1247

(multiple-value-bind (determination known-p)

1248

(agent-capability agent capability)

1249

;; check for a known determination for the agent-action combination

1250

(cond (known-p

1251

determination)

1252

(t

1253

;; if none is known, derive and cache the specific result

1254

(setf determination (call-next-method))

1255

(setf (agent-capability agent capability) determination)))

1256

             (log-debug "access-authorized-p: access cached ~s ~s ~s ~s" target agent action determination)

1257

determination))))

1258

1259

(:method :around ((context authorization) (target authorized-resource) (agent t) (action t))

1260

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

1261

(log-debug "access-authorized-p: ~s ~s ~s ~s -> ~s"

1262

context target agent action result)

1263

result))

1264

1265

(:method ((context task) (target authorized-resource) (agent t) (action t))

1266

(access-authorized-p (task-repository context) target agent action))

1267

1268

(:method ((context authorized-resource) (target null) (agent t) (action t))

1269

(access-authorized-p (resource-authorization-list context) context agent action))

1270

(:method ((context t) (target authorized-resource) (agent t) (action t))

1271

(let ((a-list (resource-authorization-list target)))

1272

(cond (a-list

1273

(access-authorized-p a-list target agent action))

1274

(t

1275

(log-warn "resource yields no authorizations: ~s" target)

1276

nil))))

1277

(:method ((context authorized-resource) (target authorized-resource) (agent t) (action t))

1278

"Determine access to the resource in a given context by testing against a combined

1279

authorization list which is that of the target reduced by that of the context."

1280

(let* ((context-list (resource-authorization-list context))

1281

(target-list (resource-authorization-list target))

1282

(a-list (combine-resource-authorization-lists target-list context-list)))

1283

(cond (a-list

1284

(access-authorized-p a-list target agent action))

1285

(t

1286

(log-warn "resource yields no authorizations: ~s x ~s" context target)

1287

nil))))

1288

1289

(:method ((context authorization-list) (target authorized-resource) (agent t) (action t))

1290

;; reduce the test to a search through the controls

1291

(let ((controls (authorization-list-controls context)))

1292

(when controls

1293

(access-authorized-p controls target agent action))))

1294

1295

(:method ((context list) (target authorized-resource) (agent t) (action t))

1296

"Test the authorization sequence - as ordered most-specific-first, to select the

1297

first match for target-in-realm and return from that the authorization state for

1298

the intended action.

1299

Ambiguity/conflict is resolved such that the first authorization which matches by domain

1300

denies or allows - as per access-to / no-access-to, and if none matches, the presence of

1301

restrictions and absence of permissions indicates that the access is authorized."

1302

(loop with no-access-tested = nil

1303

with access-tested = nil

1304

for authorization in context

1305

for to = (authorization-access-to authorization)

1306

for not-to = (authorization-no-access-to authorization)

1307

do (progn

1308

(when (and not-to (identifier-in-realm-p target not-to))

1309

(if (access-authorization-authorizes-p authorization target agent action)

1310

(return nil)

1311

(setf no-access-tested t)))

1312

(when (and to (identifier-in-realm-p target to))

1313

(if (access-authorization-authorizes-p authorization target agent action)

1314

(return t)

1315

(setf access-tested t))))

1316

finally (return (and (not access-tested) no-access-tested))))

1317

1318

;; the base methods authorize an agent or anonymous for an anonymous authorization

1319

(:method ((context t) (target t) (agent t) (action t))

1320

nil))

1321

1322

(defgeneric access-authorization-authorizes-p (authorization resource agent action)

1323

   (:documentation "Used by access-authorized-p to test the requested mode against an authorization entry .")

1324

(:method ((context t) (target t) (agent t) (action t))

1325

nil)

1326

(:method ((authorization authorization) (target authorized-resource) (agent agent) (action t))

1327

"this, the base method for authorizations, tests that the action is specified."

1328

(find action (authorization-access-mode authorization)))

1329

1330

(:method ((authorization anonymous-authorization) (target authorized-resource) (agent null) (action t))

1331

(find action (authorization-access-mode authorization)))

1332

1333

(:method ((authorization location-authorization) (target authorized-resource) (agent agent) (action t))

1334

(and (loop with location = (agent-location agent)

1335

for predicate in (authorization-location-predicates authorization)

1336

when (funcall predicate location)

1337

return t)

1338

(call-next-method)))

1339

1340

   (:method ((authorization authenticated-authorization) (target authorized-resource) (account account) (action t))

1341

(agent-equal-p account (authorization-agent-id authorization)))

1342

1343

   (:method ((authorization authenticated-authorization) (target authorized-resource) (agent agent) (action t))

1344

"When authentication is required, if an id is specified, it must match.

1345

Otherwise, permit a match by class."

1346

(let ((authorization-agent-id (authorization-agent-id authorization)))

1347

;; first, check if the agent matches

1348

(and (case authorization-agent-id

1349

((nil |urn:dydra|:|User|)

1350

(case (authorization-agent-class authorization)

1351

(|urn:dydra|:|LocatedAgent|

1352

(agent-location agent))

1353

((|urn:dydra|:|User| |urn:dydra|:|Account|)

1354

(agent-identifier agent))))

1355

(|http://xmlns.com/foaf/0.1/|:|Agent| ; anomalous

1356

t)

1357

(t

1358

(progn

1359

                 (log-debug "access-authorized-p: test agent: ~s ~s " (agent-identifier agent) authorization-agent-id)

1360

(agent-equal-p agent authorization-agent-id))))

1361

(progn

1362

(log-debug "access-authorized-p: agent matched ~s " agent)

1363

t)

1364

;; continue, to test the action

1365

(call-next-method)))))

1366

1367

1368

(defgeneric anonymous-authorization-p (object)

1369

(:method ((object t)) nil)

1370

(:method ((object anonymous-authorization)) t)

1371

(:method ((object authenticated-authorization))

1372

(eq (authorization-agent-id object) '|http://xmlns.com/foaf/0.1/|:|Agent|))

1373

(:method ((authorization-list authorization-list))

1374

(some #'anonymous-authorization-p (authorization-list-controls authorization-list))))

1375

1376

(defgeneric anonymous-access-authorized-p (target)

1377

(:documentation "Return true iff anonymous access is, in general permitted,

1378

that is, without the an agent and without respect to the action.")

1379

(:method ((authorization-list authorization-list))

1380

(some #'anonymous-authorization-p (authorization-list-controls authorization-list)))

1381

(:method ((target authorized-resource))

1382

(let ((acl-list (resource-authorization-list target)))

1383

(when acl-list (anonymous-access-authorized-p acl-list)))))

1384

1385

1386

1387

(defgeneric resource-authorization-list (resource)

1388

(:method ((resource authorized-resource))

1389

(or (get-resource-authorization-list resource)

1390

(let ((*agent* (system-agent)))

1391

           (setf-resource-authorization-list (read-resource (make-resource-authorization-list resource)) resource)))))

1392

1393

(defgeneric make-resource-authorization-list (resource &rest args)

1394

(:method ((resource authorized-resource) &rest args)

1395

(declare (dynamic-extent args))

1396

(apply #'make-instance 'authorization-list

1397

:resource resource

1398

args)))

1399

1400

1401

(defgeneric combine-resource-authorization-lists (base restrictions)

1402

(:method :around ((l1 t) (l2 t))

1403

(if (eq l1 l2)

1404

l1

1405

(call-next-method)))

1406

(:method ((base list) (restrictions list))

1407

(flet ((more-restrictive (restriction)

1408

(loop for base-authorization in base

1409

when (authorization-less-p restriction base-authorization)

1410

return t)))

1411

(declare (dynamic-extent #'more-restrictive))

1412

(append (remove-if-not #'more-restrictive restrictions) base)))

1413

(:method ((base authorization-list) (restrictions t))

1414

(combine-resource-authorization-lists (authorization-list-controls base) restrictions))

1415

(:method ((base t) (restrictions authorization-list))

1416

(combine-resource-authorization-lists base (authorization-list-controls restrictions))))

1417

1418

;;; (compute-resource-authorization-list "james/test")

1419

1420

1421

(defgeneric authorization-less-p (one-authorization other-authorization)

1422

(:documentation "return true iff the one autorization applies to a proper subset of agents

1423

and allows a proper subset of privileges compared to the other.")

1424

(:method ((one authorization) (other authorization))

1425

(flet ((compare-realms (r1 r2)

1426

(if (and r1 r2)

1427

(compare-authorization-realms r1 r2)

1428

0)))

1429

(let ((to-one (authorization-access-to one))

1430

(to-other (authorization-access-to other))

1431

(not-to-one (authorization-no-access-to one))

1432

(not-to-other (authorization-no-access-to other)))

1433

(or (and not-to-one to-other (ecase (compare-realms not-to-one to-other)

1434

((-1 0) t) ((1 nil) nil)))

1435

(and (ecase (compare-realms to-one to-other)

1436

((-1 0) t) ((1 nil) nil))

1437

(ecase (compare-realms not-to-one not-to-other)

1438

((-1 0) t) ((1 nil) nil))

1439

(ecase (compare-authorization-agent-ids one other)

1440

((-1 0) t) ((1 nil) nil))

1441

                  (ecase (compare-authorization-modes (authorization-access-mode one) (authorization-access-mode other))

1442

((-1 0) t) ((1 nil) nil))))))))

1443

1444