;; webid-oidc, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(define-module (webid-oidc rdf-index)
#:use-module (oop goops)
#:use-module (rdf rdf)
#:use-module (web uri)
#:export
(
with-index
))
(define (normalize uri)
;; It is possible to hide triples by percent-escaping
;; some characters, so that match will fail to see
;; them. With normalization, it should be impossible.
(when (string? uri)
(set! uri (string->uri uri)))
(let ((scheme (uri-scheme uri))
(userinfo (uri-userinfo uri))
(host (uri-host uri))
(port (uri-port uri))
(path (uri-path uri))
(query (uri-query uri))
(fragment (uri-fragment uri)))
(let ((normalized-scheme scheme)
(normalized-userinfo userinfo)
(normalized-host host)
(normalized-port port)
(normalized-path
(let ((path-ends-in-slash? (string-suffix? "/" path)))
(string-append
"/"
(encode-and-join-uri-path
(split-and-decode-uri-path path))
(if (and (not (equal? path "/"))
path-ends-in-slash?)
"/"
""))))
(normalized-query
(and query
(uri-encode (uri-decode query))))
(normalized-fragment
(and fragment
(uri-encode (uri-decode fragment)))))
(build-uri normalized-scheme
#:userinfo normalized-userinfo
#:host normalized-host
#:port normalized-port
#:path normalized-path
#:query normalized-query
#:fragment normalized-fragment))))
(define (normalize-object object)
(if (string? object)
(uri->string (normalize object))
object))
(define-class ()
(triples #:init-keyword #:triples #:getter triples)
(subject-index #:init-thunk (lambda () (make-hash-table))
#:getter subject-index)
(predicate-index #:init-thunk (lambda () (make-hash-table))
#:getter predicate-index)
(object-index #:init-thunk (lambda () (make-hash-table))
#:getter object-index))
(define (build-index triples)
(let ((ret (make #:triples (list->vector triples))))
(define (do-index n triples)
(unless (null? triples)
(let ((first (car triples))
(rest (cdr triples)))
(let ((s (normalize-object (rdf-triple-subject first)))
(p (normalize-object (rdf-triple-predicate first)))
(o (normalize-object (rdf-triple-object first))))
(let ((other-s (hash-ref (subject-index ret) s '()))
(other-p (hash-ref (predicate-index ret) p '()))
(other-o (hash-ref (object-index ret) o '()))
(i (- n 1)))
(hash-set! (subject-index ret) s (cons i other-s))
(hash-set! (predicate-index ret) p (cons i other-p))
(hash-set! (object-index ret) o (cons i other-o))))
(do-index (- n 1) rest))))
(do-index (length triples) (reverse triples))
ret))
(define (intersection-2 a b)
(cond
((not a) b)
((not b) a)
((or (null? a) (null? b))
'())
((< (car a) (car b))
(intersection-2 (cdr a) b))
((> (car a) (car b))
(intersection-2 a (cdr b)))
(else
(cons (car a) (intersection-2 (cdr a) (cdr b))))))
(define (intersection a . rest)
(if (null? rest)
a
(let ((b (car rest))
(true-rest (cdr rest)))
(apply intersection (intersection-2 a b) true-rest))))
(define (rdf-match index subject predicate object)
(let ((by-subject
(and subject
(hash-ref (subject-index index)
(normalize-object subject)
'())))
(by-predicate
(and predicate
(hash-ref (predicate-index index)
(normalize-object predicate)
'())))
(by-object
(and object
(hash-ref (object-index index)
(normalize-object object)
'()))))
(let ((indices (intersection by-subject by-predicate by-object)))
(define (accumulate-triples acc i)
(if (null? i)
(reverse acc)
(let ((t (vector-ref (triples index) (car i))))
(accumulate-triples (cons t acc) (cdr i)))))
(if indices
(accumulate-triples '() indices)
(vector->list (triples index))))))
(define (with-index graph f)
(let ((index (build-index graph)))
(f (lambda (s p o)
(rdf-match index s p o)))))