;; disfluid, 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)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:declarative? #t
#:export
(
with-index
))
(define normalize
(match-lambda
((and (= uri-scheme scheme)
(= uri-userinfo userinfo)
(= uri-host host)
(= uri-port port)
(= uri-path path)
(= uri-query query)
(= uri-fragment fragment))
(let ((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 scheme
#:userinfo userinfo
#:host host
#:port port
#:path normalized-path
#:query normalized-query
#:fragment normalized-fragment)))))
(define normalize-object
(match-lambda
((? string? (= string->uri (? uri? x)))
(uri->string (normalize x)))
(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))))
(let do-index ((n (length triples))
(triples (reverse triples)))
(match triples
(() ret)
((($ rdf-triple
(= normalize-object s)
(= normalize-object p)
(= normalize-object o))
triples ...)
(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 `(,i ,@other-s))
(hash-set! (predicate-index ret) p `(,i ,@other-p))
(hash-set! (object-index ret) o `(,i ,@other-o)))
(do-index (- n 1) triples))))))
(define intersection-2
;; Intersection of two lists of integers, but if one is false, only
;; consider the other.
(match-lambda*
((or (#f x) (x #f)) x)
((or (() _) (_ ())) '())
((and (a b)
((hda tla ...) (hdb tlb ...)))
(cond ((< hda hdb) (intersection-2 tla b))
((> hda hdb) (intersection-2 a tlb))
(else `(,hda ,@(intersection-2 tla tlb)))))))
(define intersection
(match-lambda*
((x) x)
((a b c ...)
(apply intersection (intersection-2 a b) c))))
(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)))
(if indices
(let accumulate-triples ((acc '())
(i indices))
(match i
(() (reverse acc))
((next i ...)
(let ((t (vector-ref (triples index) next)))
(accumulate-triples `(,t ,@acc) i)))))
(vector->list (triples index))))))
(define (with-index graph f)
(f (cute rdf-match (build-index graph) <> <> <>)))