(define-module (webid-oidc server resource path)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (webid-oidc rdf-index)
  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
  #:use-module (web uri)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 threads)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:export
  (

   read-path
   update-path

   ))

(define (default-dir)
  (string-append (refresh:default-dir) "/server"))

(define (hash-path path)
  (let ((h (stubs:hash 'SHA-256 path))
        (dir (default-dir)))
    (let ((first-char (substring h 0 1))
          (rest (substring h 1)))
      (format #f "~a/path/~a/~a" dir first-char rest))))

(define (read-path path)
  (let ((h (hash-path path)))
    (with-exception-handler
        (lambda (error)
          (let ((with-slash (string-append path "/"))
                (without-slash
                 (if (string-suffix? "/" path)
                     (substring path 0 (- (string-length path) (string-length "/")))
                     path)))
            (let ((with-slash-exists (file-exists? (hash-path with-slash)))
                  (without-slash-exists (file-exists? (hash-path without-slash))))
              (cond
               (with-slash-exists
                (raise-exception
                 (make-exception
                  (make-path-not-found path)
                  (make-uri-slash-semantics-error path with-slash))))
               (without-slash-exists
                (raise-exception
                 (make-exception
                  (make-path-not-found path)
                  (make-uri-slash-semantics-error path with-slash))))
               (else
                (raise-exception (make-path-not-found path)))))))
      (lambda ()
        (call-with-input-file h
          (lambda (port)
            (let ((main-etag (read port)))
              (let ((auxiliary (read port)))
                (values main-etag
                        (map (lambda (cell)
                               (let ((key (string->uri (car cell)))
                                     (value (string->uri (cdr cell))))
                                 (cons key value)))
                             auxiliary))))))))))

(define* (update-path path f content-type contained static-content create delete
                      #:key (create-intermediate-containers? #f))
  (let ((h (hash-path path))
        (garbage (make-hash-table))
        (has-been-created? #f)
        (has-been-deleted? #f)
        (parent-path
         (let ((components (split-and-decode-uri-path path)))
           (cond
            ((null? components)
             #f)
            ((null? (cdr components))
             "/")
            (else
             (string-append
              "/"
              (encode-and-join-uri-path
               (reverse
                (cdr
                 (reverse components))))
              "/"))))))
    (stubs:atomically-update-file
     h
     (lambda (port)
       (receive (etag auxiliary)
           (with-exception-handler
               (lambda (error)
                 (unless (path-not-found? error)
                   (raise-exception error))
                 (set! has-been-created? #t)
                 (values #f #f))
             (lambda ()
               (read-path path))
             #:unwind? #t
             #:unwind-for-type &path-not-found)
         (when etag
           (hash-set! garbage etag #t))
         (when auxiliary
           (for-each
            (lambda (cell)
              (when (cdr cell)
                (hash-set! garbage (cdr cell) #t)))
            auxiliary))
         (call-with-values
             (lambda ()
               (f etag auxiliary))
           (case-lambda
             ((false)
              (when false
                (error "You’re using the API wrong."))
              ;; Delete the resource
              (unless (null? (contained etag))
                (raise-exception (make-container-not-empty path)))
              (when (equal? path "/")
                (raise-exception (make-cannot-delete-root)))
              (set! has-been-deleted? #t)
              #f)
             ((new-etag new-auxiliary)
              (unless (and (string? new-etag) (list? new-auxiliary))
                (error "You’re using the API wrong."))
              (hash-remove! garbage new-etag)
              (when new-auxiliary
                (for-each
                 (lambda (cell)
                   (hash-remove! garbage (cdr cell)))
                 new-auxiliary))
              (write new-etag port)
              (write (map (lambda (cell)
                            (cons (uri->string (car cell))
                                  (cdr cell)))
                          new-auxiliary)
                     port)
              #t))))))
    (when (and parent-path has-been-created? (not has-been-deleted?))
      (update-path
       parent-path
       (lambda (etag auxiliary)
         ;; Add path as a child of the resource at etag
         (unless create-intermediate-containers?
           (unless etag
             ;; Typically, POST to a non-existing path
             (raise-exception (make-path-not-found parent-path))))
         (unless auxiliary
           (set! auxiliary '()))
         (let ((content-type (if etag (content-type etag) 'text/turtle))
               (other-children (if etag (contained etag) '()))
               (static-content (if etag (static-content etag) (string->utf8 ""))))
           (unless (eq? content-type 'text/turtle)
             (raise-exception (make-not-a-container parent-path content-type)))
           (let ((new-etag
                  (create content-type (cons path other-children) static-content)))
             (values new-etag auxiliary))))
       content-type contained static-content create delete
       #:create-intermediate-containers? create-intermediate-containers?))
    (when (and parent-path has-been-deleted? (not has-been-created?))
      (update-path
       parent-path
       (lambda (etag auxiliary)
         (unless etag
           (raise-exception (make-path-not-found parent-path)))
         (let ((content-type (content-type etag))
               (all-children (contained etag))
               (static-content (static-content etag)))
           (values
            (create content-type
                    (filter (lambda (x)
                              (not (equal? x path)))
                            all-children)
                    static-content)
            auxiliary)))
       content-type contained static-content create delete
       #:create-intermediate-containers? create-intermediate-containers?))
    (for-each
     delete
     (hash-map->list (lambda (garbage false) garbage) garbage))))