;; 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 <https://www.gnu.org/licenses/>.

(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 <rdf-index> ()
  (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 <rdf-index> #: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) <> <> <>)))