Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/encoding/sparql-results-graphviz.lisp

Kind	Covered	All	%
expression	241	846	28.5
branch	13	94	13.8

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

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

2

3

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

4

5

;;; results+graphviz serializer

6

7

(defparameter *graphviz-limit* 4096)

8

9

(defparameter *graphviz-attributes* ())

10

(defparameter *graphviz-rankdir* "LR")

11

(defparameter *graphviz-fontname* "courier")

12

13

(defgeneric write-sparql-results+graphviz (generator stream &key pretty start end)

14

(:documentation "Encode the result field as a .dot document.

15

Distinguish a graph field from a solution field.

16

    For the former encoded edges with the subject as head, the predicate as the edge label and the object as tail and,

17

if a context is present, collate statements in to subgraphs."))

18

19

(defmethod write-sparql-results+graphviz ((results list-solution-field) (stream t) &rest options)

20

(declare (dynamic-extent options))

21

(apply #'write-sparql-results+graphviz

22

(cons (list-solution-field-dimensions results) (list-solution-field-solutions results))

23

stream

24

options))

25

26

(defmethod write-sparql-results+graphviz ((results t) (stream t) &rest options)

27

(log-warn "write-sparql-results+graphviz: unsupported result type: ~s . ~s" (type-of results) options))

28

29

(defmethod write-sparql-results+graphviz ((result symbol) (stream t) &rest options)

30

(declare (ignore options))

31

;; do nothing

32

)

33

34

(defmethod write-sparql-results+graphviz ((results boolean-generator) (stream t) &rest options)

35

(declare (ignore options))

36

;; do nothing

37

)

38

39

40

(defmethod write-sparql-results+graphviz ((results cons) (stream t) &key

41

(label (task-id *task*))

42

                                           (start (or (response-offset) 0))

43

                                           (end (min (or (response-end) (+ start *graphviz-limit*))

44

                                                     (+ start *graphviz-limit*)))

45

                                           ((:pretty setf.dot:*pretty*) setf.dot:*pretty*)

46

                                           ;; note: for future configuration

47

                                           (attributes *graphviz-attributes*)

48

                                           (rankdir (getf attributes :rankdir *graphviz-rankdir*))

49

                                           (fontname (getf attributes :fontname *graphviz-fontname*))

50

                                           (edge (getf attributes :edge `(:fontname ,fontname)))

51

                                           (node  (getf attributes :node `(:fontname ,fontname))))

52

(let* ((dimensions (first results))

53

(solutions (rest results))

54

(*gensym-counter* 0)

55

(node-cache (make-hash-table :test 'eql))

56

(subject-cache (make-hash-table :test 'eql))

57

(label-stream (make-string-output-stream))

58

(*expand-literal-values* nil)

59

(subject-count 0)

60

(statements-returned 0)

61

(*namespace-bindings* (metadata-namespace-bindings *task*)))

62

(labels ((encode-object-label (term)

63

(encode-turtle-object term label-stream)

64

(let ((label (get-output-stream-string label-stream)))

65

(typecase term

66

(iri (setf label (iri-label (subseq label 1 (1- (length label))))))

67

(t ))

68

(when (zerop (length label))

69

(log-warn "bad label: ~s" term)

70

(setf label (string (gensym "label"))))

71

label))

72

(in-namespace-p (iri namespace-name)

73

(let ((lexical-form (iri-lexical-form iri)))

74

(and (> (length lexical-form) (length namespace-name))

75

                         (string= lexical-form namespace-name :end1 (length namespace-name)))))

76

(put-solution-field ()

77

(loop for index from 0

78

for solution in solutions

79

until (and end (>= subject-count end))

80

do (let* ((subject (first solution))

81

(s-id (setf.dot::context-id setf.dot:*context* subject))

82

                              (is-first-reference (null (gethash s-id subject-cache))))

83

;; note first appearance of each subject and use that to

84

;; determine slice position

85

(when is-first-reference

86

(setf (gethash s-id subject-cache) subject-count)

87

(incf subject-count))

88

(loop for name in dimensions for value in solution

89

                           for edge-keyword = (find name setf.dot::*edge-keywords* :test #'string-equal)

90

                           for node-keyword = (find name setf.dot::*node-keywords* :test #'string-equal)

91

if edge-keyword

92

                           collect edge-keyword into edge-attributes and collect value into edge-attributes

93

else if node-keyword

94

                           collect node-keyword into node-attributes and collect value into node-attributes

95

                           else collect (let ((id (setf.dot::context-id setf.dot:*context* value)))

96

(unless (gethash id node-cache)

97

                                       (setf (gethash id node-cache) (list :label (encode-object-label value))))

98

id)

99

into ids

100

finally (progn

101

(when (> subject-count start)

102

(incf statements-returned)

103

(when ids

104

                                         (apply #'setf.dot::context-put-edge* setf.dot:*context*

105

edge-attributes ids)

106

                                         (loop for id in ids do (incf (getf (gethash id node-cache) :reference-count 0)))))

107

(when node-attributes

108

(setf (gethash s-id node-cache)

109

                                             (append (gethash s-id node-cache) node-attributes)))))))

110

111

                  (loop for id being each hash-key of node-cache using (hash-value node-attributes)

112

;; emit only if it appeared on some edge subject to slice contraints

113

when (typep (getf node-attributes :reference-count) '(integer 1))

114

do (progn (remf node-attributes :reference-count)

115

                         (apply #'setf.dot::context-put-node setf.dot:*context* id node-attributes))))

116

(put-graph-field ()

117

(loop for index from 0

118

for (s p o . nil) in solutions ; what to do with the graph?

119

until (and end (>= subject-count end))

120

for name = (iri-local-part p)

121

                     for p-keyword = (when (in-namespace-p p "http://www.graphviz.org/doc/info/attrs.html#")

122

                                       (find name setf.dot::*node-keywords* :test #'string-equal))

123

for p-label = (encode-object-label p)

124

for s-id = (setf.dot::context-id setf.dot:*context* s)

125

for o-id = (setf.dot::context-id setf.dot:*context* o)

126

for is-first-reference = (null (gethash s-id subject-cache))

127

when is-first-reference

128

do (progn (setf (gethash s-id subject-cache) subject-count)

129

(incf subject-count))

130

unless (gethash s-id node-cache)

131

                     do (setf (gethash s-id node-cache) (list :label (encode-object-label s)))

132

if p-keyword

133

do (progn (setf (getf (gethash s-id node-cache) p-keyword) o)

134

(when (> subject-count start)

135

                            (incf (getf (gethash s-id node-cache) :reference-count 0))))

136

else do (progn

137

(unless (gethash o-id node-cache)

138

                                 (setf (gethash o-id node-cache) (list :label (encode-object-label o))))

139

(when (> subject-count start)

140

                                 (progn (setf.dot::context-put-edge setf.dot:*context* s-id o-id :label p-label)

141

(incf statements-returned)

142

                                   (incf (getf (gethash s-id node-cache) :reference-count 0))

143

                                   (incf (getf (gethash o-id node-cache) :reference-count 0))))))

144

                   (loop for id being each hash-key of node-cache using (hash-value node-attributes)

145

                     ;; emit only if it appeared on some edge subject to slice contraints

146

when (typep (getf node-attributes :reference-count) '(integer 1))

147

do (progn (remf node-attributes :reference-count)

148

                          (apply #'setf.dot::context-put-node setf.dot:*context* id node-attributes)))))

149

         (apply #'dot:context-put-graph (make-instance 'setf.dot:stream :stream stream :pretty *print-pretty*)

150

label

151

(cond ((or (equal dimensions *construct-dimensions*)

152

(equal dimensions *quad-dimensions*))

153

#'put-graph-field)

154

(dimensions

155

#'put-solution-field)

156

(t ; do nothing

157

#'(lambda ())))

158

:rankdir rankdir

159

:fontname fontname

160

:edge edge

161

:node node

162

attributes))

163

(incf *statements-returned* statements-returned)))

164

165

(defparameter *write-sparql-results+graphviz-mode* :star-graph

166

"the options are :stargraph and :hypergraph")

167

(defparameter *write-sparql-results+graphviz-length-limit* 64)

168

169

(defmethod write-sparql-results+graphviz ((results solution-generator) (stream t) &key

170

(label (task-id *task*))

171

                                           (start (or (response-offset) 0))

172

                                           (end (min (or (response-end) (+ start *graphviz-limit*))

173

                                                     (+ start *graphviz-limit*)))

174

                                           ((:pretty setf.dot:*pretty*) setf.dot:*pretty*)

175

                                           ;; note: for future configuration

176

                                           (attributes *graphviz-attributes*)

177

                                           (rankdir (getf attributes :rankdir *graphviz-rankdir*))

178

                                           (fontname (getf attributes :fontname *graphviz-fontname*))

179

                                           (edge (getf attributes :edge `(:fontname ,fontname)))

180

                                           (node  (getf attributes :node `(:fontname ,fontname))))

181

(let* ((dimensions (solution-generator-dimensions results))

182

(channel (solution-generator-channel results))

183

(base-width (length dimensions))

184

(index 0)

185

(*gensym-counter* 0)

186

(node-cache (make-hash-table :test 'eql))

187

(subject-cache (make-hash-table :test 'eql))

188

(label-stream (make-string-output-stream))

189

(*expand-literal-values* nil)

190

(subject-count 0)

191

(statements-returned 0)

192

#+(or)(term-deconstructor (repository-term-deconstructor *transaction*))

193

(*namespace-bindings* (metadata-namespace-bindings *task*)))

194

(labels ((encode-term-id-label (term-id)

195

(case term-id

196

(0 "null")

197

(-1 "<urn:dydra:default>")

198

(-2 "<urn:dydra:named>")

199

(t (let ((label (progn (encode-turtle-term-number term-id label-stream)

200

(get-output-stream-string label-stream))))

201

;; unescape it as the graphviz output does its own

202

(when (and (> (length label) 0) (eql (char label 0) #\"))

203

(setf label (elt (tokenize-sparql label) 0)))

204

(cond ((repository-term-is-iri *transaction* term-id)

205

(setf label (iri-label label)))

206

((zerop (length label))

207

                               (log-warn "write-sparql-results+graphviz: bad label: ~s" term-id)

208

(setf label (string (gensym "label"))))

209

                              ((> (length label) *write-sparql-results+graphviz-length-limit*)

210

                               (setf label (concatenate 'string (subseq label 0 *write-sparql-results+graphviz-length-limit*) "..."))))

211

label))))

212

(term-puri (term-id)

213

(let ((lexical-form (progn (encode-turtle-term-number term-id label-stream)

214

                                       (get-output-stream-string label-stream))))

215

;; allow both real iris and string lexical forms

216

                   (when (or (char= #\< (char lexical-form 0)) (char= #\" (char lexical-form 0)))

217

(setf lexical-form (subseq lexical-form 1 (1- (length lexical-form)))))

218

(handler-case (puri:uri lexical-form)

219

(error (c)

220

                            (log-warn "write-sparql-results+graphviz: invalid iri syntax: ~s: ~a"

221

lexical-form c)

222

(load-time-value (puri:uri ""))))))

223

(in-namespace-p (iri namespace-name)

224

(let ((lexical-form (iri-lexical-form iri)))

225

(and (> (length lexical-form) (length namespace-name))

226

                        (string= lexical-form namespace-name :end1 (length namespace-name)))))

227

(encode-rdf-field-as-dot (page index start end)

228

(let ((width (array-dimension page 1))

229

(length (array-dimension page 0)))

230

(loop for page-index below length

231

until (and end (>= subject-count end))

232

do (incf statements-returned)

233

do (let* ((s-id (aref page page-index 0))

234

                               (is-first-reference (null (gethash s-id subject-cache))))

235

;; note first appearance of each subject and use that to

236

;; determine slice position

237

(when is-first-reference

238

(setf (gethash s-id subject-cache) subject-count)

239

(incf subject-count))

240

(ecase *write-sparql-results+graphviz-mode*

241

(:hypergraph

242

                             (loop for name in dimensions for value-index from 0 below width

243

                               for edge-keyword = (find name setf.dot::*edge-keywords* :test #'string-equal)

244

                               for node-keyword = (find name setf.dot::*node-keywords* :test #'string-equal)

245

for term-id = (aref page page-index value-index)

246

if edge-keyword

247

collect edge-keyword into edge-attributes

248

                               and collect (encode-term-id-label term-id) into edge-attributes

249

else if node-keyword

250

collect node-keyword into node-attributes

251

                               and collect (encode-term-id-label term-id) into node-attributes

252

else collect (progn

253

                                              (unless (gethash term-id node-cache)

254

                                                (setf (getf (gethash term-id node-cache) :label)

255

                                                      (encode-term-id-label term-id)))

256

term-id)

257

into ids

258

finally (progn

259

(when (> subject-count start)

260

(when ids

261

                                             (apply #'setf.dot::context-put-edge* setf.dot:*context*

262

                                                    edge-attributes ids)

263

                                             (loop for id in ids do (incf (getf (gethash id node-cache) :reference-count 0)))))

264

(when node-attributes

265

(setf (gethash s-id node-cache)

266

                                                 (append (gethash s-id node-cache) node-attributes))))))

267

(:star-graph

268

(let ((subject-id (aref page page-index 0)))

269

(unless (gethash subject-id node-cache)

270

(let ((label (encode-term-id-label subject-id)))

271

(setf (gethash subject-id node-cache) label)

272

                                 (setf.dot::context-put-node setf.dot:*context* subject-id :label label)))

273

                             (loop for name in (rest dimensions) for value-index from 1 below width

274

for term-id = (aref page page-index value-index)

275

for term-label = (encode-term-id-label term-id)

276

unless (eql 0 term-id)

277

do (progn (unless (gethash term-id node-cache)

278

                                           (let ((label (encode-term-id-label term-id)))

279

                                             (setf (gethash term-id node-cache) label)

280

                                             (setf.dot::context-put-node setf.dot:*context* term-id :label label)))

281

                                    (setf.dot::context-put-edge setf.dot:*context* subject-id term-id :label (string name))))))))

282

finally (return (+ index page-index)))))

283

(put-solution-field ()

284

(do-pages (page channel)

285

                              (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))

286

(when (and end (>= index end))

287

(return))

288

(if (>= (+ index (array-dimension page 0)) start)

289

(cond ((= base-width (array-dimension page 1))

290

                                         (trace-data write-sparql-results+graphviz dimensions (term-value-field page))

291

                                         (setf index (encode-rdf-field-as-dot page index start end)))

292

(t

293

                                         (log-warn "field width mismatch: ~s : ~s."

294

                                                   dimensions (array-dimension page 1))

295

                                         (incf index (array-dimension page 0))))

296

(incf index (array-dimension page 0))))

297

(if (eq *write-sparql-results+graphviz-mode* :hypergraph)

298

;; emit the saved nodes

299

                     (loop for id being each hash-key of node-cache using (hash-value node-attributes)

300

when (typep (getf node-attributes :reference-count) '(integer 1))

301

do (progn (remf node-attributes :reference-count)

302

                            (apply #'setf.dot::context-put-node setf.dot:*context* id node-attributes)))))

303

(encode-rdf-graph-as-dot (page index start end)

304

(let ((length (array-dimension page 0)))

305

(loop for page-index below length

306

until (and end (>= subject-count end))

307

for s-id = (aref page page-index 0)

308

for p-id = (aref page page-index 1)

309

for p-puri = (term-puri p-id)

310

for p-label = (iri-label p-puri)

311

for p-name = (iri-local-part p-puri)

312

                     for node-keyword = (when (in-namespace-p p-puri "http://www.graphviz.org/doc/info/attrs.html#")

313

                                          (find p-name setf.dot::*node-keywords* :test #'string-equal))

314

for o-id = (aref page page-index 2) ;; ignore graph

315

for is-first-reference = (null (gethash s-id subject-cache))

316

when is-first-reference

317

do (progn (setf (gethash s-id subject-cache) subject-count)

318

(incf subject-count))

319

unless (gethash s-id node-cache)

320

                     do (setf (gethash s-id node-cache) (list :label (encode-term-id-label s-id)))

321

if node-keyword

322

                     do (progn (setf (getf (gethash s-id node-cache) node-keyword) (encode-term-id-label o-id))

323

(when (> subject-count start)

324

                            (incf (getf (gethash s-id node-cache) :reference-count 0))))

325

else do (progn

326

(unless (gethash o-id node-cache)

327

                                 (setf (gethash o-id node-cache) (list :label (encode-term-id-label o-id))))

328

(when (> subject-count start)

329

                                 (progn (setf.dot::context-put-edge setf.dot:*context* s-id o-id :label p-label)

330

(incf statements-returned)

331

                                   (incf (getf (gethash s-id node-cache) :reference-count 0))

332

                                   (incf (getf (gethash o-id node-cache) :reference-count 0)))))

333

finally (return (+ index page-index)))))

334

(put-graph-field ()

335

(do-pages (page channel)

336

                  (assert (= (length (array-dimensions page)) 2) () "invalid result array dimensions: ~a" (array-dimensions page))

337

(when (and end (>= subject-count end))

338

(return))

339

(if (>= (+ index (array-dimension page 0)) start)

340

(cond ((= base-width (array-dimension page 1))

341

                             (trace-data write-sparql-results+graphviz dimensions (term-value-field page))

342

                             (setf index (encode-rdf-graph-as-dot page index start end)))

343

(t

344

(log-warn "field width mismatch: ~s : ~s."

345

dimensions (array-dimension page 1))

346

(incf index (array-dimension page 0))))

347

(incf index (array-dimension page 0))))

348

                (loop for id being each hash-key of node-cache using (hash-value node-attributes)

349

;; emit only if it appeared on some edge subject to slice contraints

350

when (typep (getf node-attributes :reference-count) '(integer 1))

351

do (progn (remf node-attributes :reference-count)

352

                       (apply #'setf.dot::context-put-node setf.dot:*context* id node-attributes)))))

353

354

          (apply #'dot:context-put-graph (make-instance 'setf.dot:stream :stream stream :pretty *print-pretty*)

355

label

356

(cond ((or (equal dimensions *construct-dimensions*)

357

(equal dimensions *quad-dimensions*))

358

#'put-graph-field)

359

(dimensions

360

#'put-solution-field)

361

(t ; do nothing

362

#'(lambda ())))

363

:rankdir rankdir

364

:fontname fontname

365

:edge edge

366

:node node

367

attributes))

368

(incf-stat *statements-returned* index)

369

index))

370

371

372

 (defmethod send-response-message ((operation t) (generator solution-generator) (stream t) (content-type mime:*/vnd.dydra.sparql-results+graphviz))

373

"Given a solution field, emit the results as as graphviz .dot document"

374

(when *encoding-trace-output*

375

(setf stream (make-broadcast-stream *encoding-trace-output* stream)))

376

(write-sparql-results+graphviz generator stream))

377

378

 (defmethod send-response-message ((operation t) (generator solution-generator) (stream t) (content-type mime:graphviz-image))

379

   "Given a solution field, emit the results as as graphviz .dot document and render that as an image"

380

(let ((pathname (tmp-export-pathname (account (repository-account *repository*))

381

(repository *repository*))))

382

(unwind-protect

383

(progn

384

           (with-open-file (dot-stream pathname :direction :output :if-exists :error :if-does-not-exist :create)

385

(call-next-method operation generator dot-stream content-type))

386

(render-dot-file pathname stream content-type))

387

(conditional-delete-file pathname))))

388

389

(defun graphviz-executable-pathname (layout)

390

(concatenate 'string "/usr/bin/" (string layout)))

391

392

(defgeneric render-dot-file (from to media-type &key layout)

393

(:method ((from pathname) (to stream) (type string) &key (layout "dot"))

394

(let ((process (run-program (graphviz-executable-pathname layout)

395

(list (concatenate 'string "-T" type)

396

"-o" "/dev/stdout"

397

(namestring from))

398

:output to

399

:wait t)))

400

(cond (process

401

(case (run-program-exit-code process)

402

(0 )

403

(t (error "graphviz generation failed: ~s." (run-program-exit-code process))))

404

(run-program-close process))

405

(t

406

(error "graphviz generation failed.")))))

407

(:method ((from t) (to pathname) (type string) &rest args)

408

(with-open-file (stream to :direction :output)

409

(apply #'render-dot-file from stream type args)))

410

411

(:method ((from t) (to t) (type mime:graphviz-image) &rest args)

412

(apply #'render-dot-file from to (de.setf.utility.implementation::mime-type-file-type type) args)))

413

414

415

(defgeneric dot-sparql (query pathname &rest args)

416

(:method ((query t) (destination pathname) &rest args)

417

(with-open-file (output-stream destination :direction :output

418

:element-type 'character

419

                                    :if-does-not-exist :create :if-exists :supersede)

420

(apply #'dot-sparql query output-stream args)))

421

(:method ((query t) (destination stream) &rest args)

422

(multiple-value-bind (results dimensions *task*)

423

(apply #'run-sparql query args)

424

(let ((*expand-literal-values* nil))

425

(with-accounting

426

(write-sparql-results+graphviz (cons dimensions results)

427

destination))))))

428

429

430

#+(or)

431

(progn

432

433

(write-sparql-results+graphviz

434

'((?::a ?::s ?::d)

435

(1 2 3)

436

(1 4 5)

437

(<http://example/1> <http://example/2> <http://example/3>))

438

*trace-output*

439

:pretty t

440

;; should include the second one only

441

:start 1)

442

443

(write-sparql-results+graphviz

444

'((?::|s| ?::|p| ?::|o|)

445

(<http://example/1> <urn:graphviz:color> "red")

446

(<http://example/1> <http://example/weight> "100")

447

(<http://example/2> <http://example/p1> <http://example/1>)

448

(<http://example/2> <http://example/21> "root"))

449

*trace-output*

450

:pretty t)

451

452

(pipe-sparql "select ?s ?p ?o where {?s ?p ?o}" *trace-output*

453

:response-content-type mime:application/sparql-results+vnd.graphviz

454

:repository-id "openrdf-sesame/mem-rdf")

455

456

;; curl

457

)