(define-module (webid-oidc server create)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc server resource path)
  #:use-module (webid-oidc server resource content)
  #:use-module (webid-oidc cache)
  #:use-module (webid-oidc fetch)
  #:use-module (webid-oidc server resource wac)
  #: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 (web client)
  #:use-module (web response)
  #:use-module (rdf rdf)
  #:use-module (turtle tordf)
  #:use-module (turtle fromrdf)
  #: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
  (

   create
   create-root

   ))

(define (without-containment-triples doc-uri content-type content)
  (case content-type
    ((text/turtle)
     #t)
    (else
     (raise-exception (make-unsupported-media-type content-type))))
  (let ((graph (fetch
                doc-uri
                #:http-get
                (lambda (uri . args)
                  (values
                   (build-response #:headers `((content-type ,content-type)))
                   content)))))
    (with-index
     graph
     (lambda (rdf-match)
       (unless (null? (rdf-match (uri->string doc-uri)
                                 "http://www.w3.org/ns/auth/acl#contains"
                                 #f))
         (raise-exception (make-incorrect-containment-triples
                           (uri-path doc-uri))))))))

(define (types-indicate-container? types)
  (and (not (null? types))
       (let ((next (car types)))
         (when (uri? next)
           (set! next (uri->string next)))
         (or (equal? next "http://www.w3.org/ns/ldp#BasicContainer")
             (types-indicate-container? (cdr types))))))

(define (check-acl-can-append server-name container owner user http-get)
  (let ((modes (wac-get-modes server-name container user #:http-get http-get)))
    (define (check-modes modes)
      (if (null? modes)
          (raise-exception
           (make-forbidden container user owner
                           (string->uri "http://www.w3.org/ns/auth/acl#Append")))
          (or
           (equal? (car modes) (string->uri "http://www.w3.org/ns/auth/acl#Append"))
           (equal? (car modes) (string->uri "http://www.w3.org/ns/auth/acl#Write"))
           (check-modes (cdr modes)))))
    (check-modes modes)))

(define* (create server-name owner user container types slug content-type content
                 #:key
                 (http-get http-get))
  (unless (equal? owner user)
    (check-acl-can-append server-name container owner user http-get))
  (unless (and slug (not (equal? slug "")))
    (set! slug (stubs:random 12)))
  (when (string-contains slug "/")
    (let ((i (string-contains slug "/")))
      (set! slug (substring slug 0 i))))
  (let ((container? (types-indicate-container? types)))
    (let ((doc-uri
           (build-uri
            (uri-scheme server-name)
            #:userinfo (uri-userinfo server-name)
            #:host (uri-host server-name)
            #:port (uri-port server-name)
            #:path
            (string-append
             "/"
             (encode-and-join-uri-path
              (append (split-and-decode-uri-path container)
                      (list slug)))
             ;; There’s no risk to have // here, because slug is
             ;; non-empty.
             (if container? "/" "")))))
      (when (and slug
                 (or (string-suffix? ".acl" slug)
                     (string-suffix? ".meta" slug)))
        (raise-exception (make-path-is-auxiliary (uri-path doc-uri))))
      (when container?
        (without-containment-triples doc-uri content-type content))
      (with-session
       (lambda (load-content-type load-contained load-static-content
                                  do-create do-delete)
         (catch 'slug-already-exists
           (lambda ()
             (update-path
              (uri-path doc-uri)
              (lambda (etag auxiliary)
                (when etag
                  (throw 'slug-already-exists))
                (values
                 (do-create content-type (and container? '()) content)
                 '()))
              load-content-type load-contained load-static-content
              do-create do-delete)
             doc-uri)
           (lambda error
             (create server-name owner user container types
                     (string-append slug "-" (stubs:random 12))
                     content-type content
                     #:http-get http-get))))))))

(define (create-root server-name owner)
  (define (fix-angle-aux accu chars)
    (if (null? chars)
        (list->string (reverse accu))
        (let ((next (car chars))
              (rest (cdr chars)))
          (let ((next-accu
                 (if (eqv? next #\>)
                     (reverse (string->list "%3E"))
                     (list next))))
            (fix-angle-aux (append next-accu accu) rest)))))
  (define (fix-angle str)
    (fix-angle-aux '() (string->list str)))
  (catch 'already-exists
    (lambda ()
      (with-session
       (lambda (load-content-type load-contained load-static-content
                                  do-create do-delete)
         (update-path
          "/"
          (lambda (etag auxiliary)
            (when etag
              (throw 'already-exists))
            (let ((root-uri
                   (build-uri
                    (uri-scheme server-name)
                    #:userinfo (uri-userinfo server-name)
                    #:host (uri-host server-name)
                    #:port (uri-port server-name)
                    #:path "/")))
              (values
               (do-create 'text/turtle '() "")
               (list
                (cons (string->uri "http://www.w3.org/ns/auth/acl#accessControl")
                      (do-create 'text/turtle #f
                                 (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> .

<#default>
  a acl:Authorization;
  acl:accessTo <~a>;
  acl:agent <~a>;
  acl:mode acl:Read, acl:Write, acl:Control;
  acl:default <~a/>.
"
                                         (fix-angle (uri->string root-uri))
                                         (fix-angle (uri->string owner))
                                         (fix-angle (uri->string root-uri)))))))))
          load-content-type load-contained load-static-content
          do-create do-delete)))
      #t)
    (lambda error
      #f)))