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

Kind	Covered	All	%
expression	0	428	0.0
branch	0	68	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; -*- package: org.dataagraph.spocq.implementation -*-

2

;;;

3

;;; translate rdf graph representation for a script into s-expression form

4

5

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

6

7

;;; (load (compile-file "/opt/spocq/patches/ssl/ssl-compiler.lisp"))

8

9

;;; load-ssl-graph

10

;;; -> read-ssl-graph

11

;;; -> parse-ssl-graph

12

;;; -> compute-ssl-graph

13

14

;;;

15

 ;;; load from a store or read the document and parse to triples, translate to an ssl code sequence with

16

;;; the top class in the graph as the initial operator. (just one permitted as no order is possible)

17

18

(defgeneric read-ssl-graph (document)

19

(:documentation "Given a location or a immediate document, read the graph either from

20

a remote location or from a local repository, both under access constraints.

21

The result is a concrete rdf graph - a collection of triples.

22

The may result from retrieving the graph from a local repository or from retrieving and

23

decoding an rdf document from a remote source.")

24

25

(:method ((value string))

26

"Given a string, interpret a singleton nquads iri as a location from which to load and return

27

the encoded graph. Otherwise return the string itself."

28

(setf value (string-trim #(#\newline #\return #\linefeed #\space #\tab) value))

29

(assert (>= (length value) 2) () "Invalid ssl graph: ~s." value)

30

(let ((start nil) (end nil))

31

(cond ((multiple-value-setq (start end)

32

(and (eql (char value 0) #\<)

33

(terminated-iri-scanner value 1 (length value))))

34

(if (eql end (length value))

35

(read-ssl-graph (intern-iri (subseq value 1 (1- (length value)))))

36

value))

37

((multiple-value-setq (start end)

38

(iri-scanner value 0 (length value)))

39

(if (eql end (length value))

40

(read-ssl-graph (intern-iri value))

41

value))

42

(t ; otherwise, the given value is the document

43

value))))

44

45

(:method ((location spocq:iri))

46

"Given an iri, if it designates a local repository, read that graph from the repository.

47

Otherwise, retrieve the remote document.

48

Exectise authorization for the active agent in the context of the current task."

49

(if (access-authorized-p location *agent* |acl|:|Execute|)

50

(multiple-value-bind (local-repository-id parsed-iri)

51

(iri-service-repository-id location)

52

(if local-repository-id

53

;; if the location is local, retrieve the designated graph

54

               (let* ((location-query-parameters (parse-query-parameters (puri:uri-query parsed-iri)))

55

(revision-id (getf location-query-parameters :revision-id))

56

                      (repository (repository *class.repository* :id local-repository-id :external-name local-repository-id))

57

                      (revision (repository-revision (or revision-id "HEAD") :reference repository :if-does-not-exist :error))

58

(graph (or (getf location-query-parameters :revision-id)

59

                                 (spocq.e:request-error "Invalid script graph location: (~s . ~s) -> ~s."

60

                                                        *task* *agent* location))))

61

(flet ((match-field (context subject predicate object)

62

                          (let ((field (repository-matrix-field *transaction* context subject predicate object)))

63

(prog1 (term-value-field field)

64

(release-field-data field)))))

65

(append (with-open-transaction (revision)

66

(match-field graph '?::s '?::p '?::o)))))

67

;; otherwise, read it from th eremote location

68

               (let ((process (run-program "/opt/dydra/lib/exec/curl" (list (spocq:iri-lexical-form location))

69

:wait nil

70

:output :stream)))

71

(unwind-protect (read-stream (run-program-output process))

72

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

73

(spocq.e:request-error "Access to process is not authorized: (~s . ~s) -> ~s."

74

*task* *agent* location)))

75

76

(:method ((location stream))

77

(read-stream location)))

78

79

80

(defgeneric parse-ssl-graph (graph)

81

(:method ((graph list))

82

;; already parsed

83

graph)

84

85

(:method ((graph-string string))

86

(let ((*namespace-bindings* *namespace-bindings*)

87

(defaults `(("spin" . "http://spinrdf.org/spin#")

88

("ssl" . ,*ssl-namespace-name*)

89

("" . ,*ssl-namespace-name*))))

90

(loop for binding in defaults

91

unless (assoc (first binding) *namespace-bindings* :test #'string=)

92

do (push binding *namespace-bindings*))

93

(parse-ssl-graph (parse-turtle graph-string)))))

94

95

96

(defgeneric compute-ssl-tree (tree)

97

(:documentation "Transform a c-b-d field into the equivalent ssl form by

98

rearranging arguments according to whether positional, keyword, or code

99

replacing properties with keywords, and consolidating forms per typed node.")

100

101

(:method ((triples cons))

102

"given a list, extract the type as the operator and any steps as single argument

103

but fold everything else into the list"

104

(let ((extracting-ids ()))

105

(labels ((extract-value (value)

106

(loop for (nil s p o) in triples

107

when (equalp s value)

108

do (case p

109

((|rdf|:|first| |rdf|:|rest|) (return (extract-list s)))

110

(|rdf|:|type| (return (extract-function s o))))

111

finally (return (typecase value

112

                                      (spocq:blank-node (make-variable (spocq:blank-node-label value)))

113

(t value)))))

114

(extract-list (id)

115

(when (member id extracting-ids)

116

(error "Circular list reference in SSL: ~s: ~s." id triples))

117

(let ((first nil)

118

(rest nil))

119

(loop for (nil s p o) in triples

120

when (equalp s id)

121

do (case p

122

(|rdf|:|first| (setf first o))

123

(|rdf|:|rest| (setf rest o))))

124

(cond ((and first rest)

125

(setf first (extract-value first))

126

(case rest

127

(|rdf|:|nil| (list first))

128

(t

129

(push id extracting-ids)

130

(cons first (extract-list rest)))))

131

(t

132

;; dotted list

133

id))))

134

(type-as-function (type)

135

(when (and (symbolp type) (fboundp type))

136

(let ((function (fdefinition type)))

137

(when (typep function 'sslr:function) function))))

138

(type-as-reference (type)

139

(when (iri-p type) (load-ssl-graph type)))

140

(extract-function (id type)

141

;; (print (list :extract id type))

142

(when (member id extracting-ids)

143

(error "Circular function reference in SSL: ~s: ~s." id triples))

144

(push id extracting-ids)

145

(let ((function (type-as-function type)))

146

(if function

147

(let* ((signature (sslr:function-signature function))

148

(required ())

149

(keyword ())

150

(code ())

151

(invalid ()))

152

                          (let ((properties (mapcar #'cddr (remove id triples :test-not #'equalp :key #'second))))

153

;; (print (list type properties))

154

(loop for (property value) in properties

155

with position = 0

156

with property-keyword = nil

157

do (cond ((eq property |rdf|:|type|)

158

(assert (equalp value type) ()

159

                                                "Invalid ssl graph: duplicate type: ~s:  ~s." id triples))

160

                                       ((setf position (when (symbolp property)

161

                                                         (position property (sslr:function-required-parameters signature)

162

                                                                   :test #'string-equal)))

163

                                        (push (cons position (extract-value value)) required))

164

                                       ((setf position (position (setf property-keyword (iri-keyword property))

165

                                                                 (sslr:function-keyword-parameters signature)))

166

                                        ;; add keywords in apparent order to the code list

167

                                        (push (list property-keyword (extract-value value)) keyword))

168

                                       ((setf position (when (symbolp property)

169

                                                         (position property (sslr:function-code-parameters signature)

170

                                                                   :test #'string-equal)))

171

                                        (push (cons position (extract-value value)) code))

172

(t

173

(push property invalid))))

174

(assert (null invalid) ()

175

                                    "Invalid ssl graph: invalid properties: ~s: ~s~% ~s." function invalid triples)

176

                            `(,@(reduce #'append (sort required #'< :key #'first) :key #'rest :from-end t)

177

,@(reduce #'append keyword :from-end t)

178

,type

179

,@(mapcar #'rest (sort code #'< :key #'first)))))

180

(let ((reference (type-as-reference type)))

181

                          ;; rearrange the retrieved reference to append any arguments and translate as above

182

(if reference

183

                              (compute-ssl-tree (append reference (remove type (copy-list triples) :key #'fourth)))

184

                              (warn "Undefined script reference: ~s: ~s." id type)))))))

185

(let ((functions (loop for (nil object a type) in triples

186

when (eq a |rdf|:|type|)

187

unless (loop for (nil nil nil o-member) in triples

188

when (equalp object o-member)

189

return :field)

190

collect (extract-function object type))))

191

(when (rest functions)

192

(warn "Multiple SSL operators: ~s." functions))

193

(first functions))))))

194

195

196

(defgeneric load-ssl-graph (location)

197

(:documentation "Given a location or an immediate document, parse the graph and

198

convert it into an ssl code sequence")

199

200

(:method ((location t))

201

(compute-ssl-tree (parse-ssl-graph (read-ssl-graph location)))))

202

203

204

205

;;; all aupplanted by the functions, above

206

#+(or)

207

(defgeneric flatten-ssl-tree (tree)

208

(:documentation "Transform a c-b-d tree into the equivalent ssl form by

209

rearranging arguments according to whether positional, keyword, or code

210

replacing properties with keywords, and flattening nested forms.")

211

212

(:method ((form cons))

213

"given a list, extract the type as the operator and any steps as single argument

214

but fold everything else into the list"

215

(let* ((type (or (getf form '|rdf|:|type|)

216

(error "Invalid ssl graph: no type: ~s." form)))

217

(reference nil))

218

(cond ((setf reference (type-as-function type))

219

                ;; translate a form which references to native functions into the script expression

220

                ;; construct a code sequence with required, then keyword arguments, then the operator

221

;; followed by code argument(s)

222

(let* ((signature (sslr:function-signature function))

223

(required ())

224

(keyword ())

225

(code ())

226

(invalid ()))

227

;; (print (cons type signature))

228

(loop for (property value) on form by #'cddr

229

with position = 0

230

with property-keyword = nil

231

do (cond ((eq property |rdf|:|type|)

232

(assert (eq value type) ()

233

                                      "Invalid ssl graph: duplicate type: ~s." form))

234

((setf position (when (symbolp property)

235

(position property

236

                                                         (sslr:function-required-parameters signature)

237

                                                         :test #'string-equal)))

238

                              (push (cons position (flatten-ssl-tree value)) required))

239

                             ((setf position (position (setf property-keyword (iri-keyword property))

240

                                                       (sslr:function-keyword-parameters signature)))

241

;; add keywords in apparent order to the code list

242

                              (push (list property-keyword (first (flatten-ssl-tree value))) keyword))

243

((setf position (when (symbolp property)

244

(position property

245

                                                         (sslr:function-code-parameters signature)

246

                                                         :test #'string-equal)))

247

(push (cons position (flatten-ssl-list value)) code))

248

(t

249

(push property invalid))))

250

(assert (null invalid) ()

251

                          "Invalid ssl graph: invalid properties: ~s: ~s~% ~s." function invalid form)

252

                  `(,@(reduce #'append (sort required #'< :key #'first) :key #'rest :from-end t)

253

,@(reduce #'append keyword :from-end t)

254

,type

255

,@(mapcar #'rest (sort code #'< :key #'first)))))

256

((setf (reference (type-as-reference type)))

257

                ;; rearrange the retrieved reference to append any arguments and translate as above

258

(setf form (copy-list form))

259

(remf form '|rdf|:|type|)

260

(flatten-ssl-form (append reference form)))

261

(t

262

(warn "Undefined script reference: ~s." type)))))

263

264

(:method ((form spocq:blank-node))

265

(list (make-variable (spocq:blank-node-label form))))

266

267

(:method ((form t))

268

(list form)))

269

270

#+(or)

271

(defgeneric flatten-ssl-list (tree)

272

(:method ((form list))

273

(reduce #'append form :key #'flatten-ssl-tree :from-end t)))

274

275

276

(defun compute-cspo-form (term statements)

277

"Given a subject term and a statement field, compute definition forms

278

- accumulate the values and initargs as a definition list "

279

(let ((initargs ()))

280

(loop for (nil subject property object) in statements

281

when (equalp subject term)

282

do (let ((value (compute-cspo-object-form object statements)))

283

(setf (getf initargs property) value)))

284

initargs))

285

286

(defun compute-cspo-object-form (term statements)

287

(typecase term

288

((or spocq:blank-node iri (satisfies variable-p))

289

(flet ((get-property (test-property)

290

;; (print test-property)

291

(loop for (nil subject property object) in statements

292

when (and (equalp subject term) (equalp property test-property))

293

return object)))

294

(cond ((get-property |rdf|:|type|)

295

(compute-cspo-form term statements))

296

((get-property |rdf|:|first|)

297

(compute-spo-form-list term statements))

298

(t

299

term))))

300

(t

301

term)))

302

303

304

(defun compute-spo-form-list (term statements)

305

   "given a graph as a list of statements and the term for the list head, compute the list of objects."

306

(if (eq term |rdf|:|nil|)

307

()

308

(loop with first = nil

309

with first-p = nil

310

with rest = nil

311

with rest-p = nil

312

for (nil subject predicate object) in statements

313

when (equal term subject)

314

do (case predicate

315

(|rdf|:|first|

316

(assert (null first) () "duplicate first in list graph: ~s" statements)

317

(setf first (compute-cspo-object-form object statements)

318

first-p t))

319

(|rdf|:|rest|

320

(assert (null rest) () "duplicate rest in list graph: ~s" statements)

321

(setf rest (compute-spo-form-list object statements)

322

rest-p t))

323

(t

324

(error "invalid predicate in list graph: ~s: ~s" predicate statements)))

325

when (and first-p rest-p)

326

return (cons first rest)

327

finally (error "head not in list graph: ~s: ~s" term statements))))

328