;; 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 resource-server)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc provider-confirmation)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc dpop-proof)
#:use-module (webid-oidc serve)
#:use-module ((webid-oidc server create) #:prefix ldp:)
#:use-module ((webid-oidc server read) #:prefix ldp:)
#:use-module ((webid-oidc server update) #:prefix ldp:)
#:use-module ((webid-oidc server delete) #:prefix ldp:)
#:use-module ((webid-oidc server resource wac) #:prefix wac:)
#:use-module ((webid-oidc server resource path) #:prefix ldp:)
#:use-module (webid-oidc server precondition)
#:use-module (webid-oidc http-link)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module ((webid-oidc config) #:prefix cfg:)
#:use-module (webid-oidc jti)
#:use-module (webid-oidc access-token)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (web server)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (webid-oidc web-i18n)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 suspendable-ports)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
#:use-module (sxml simple)
#:use-module (srfi srfi-19)
#:declarative? #t
#:export
(
make-authenticator
make-resource-server
))
(define* (make-authenticator #:key (server-uri #f))
(unless (and server-uri (uri? server-uri))
(fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri).")))
(lambda (request request-body)
(let ((headers (request-headers request))
(uri (request-uri request))
(method (request-method request))
(current-time ((p:current-date))))
(parameterize ((web-locale request)
(p:current-date current-time)) ;; fix the date
(let ((authz (assoc-ref headers 'authorization))
(dpop (assoc-ref headers 'dpop))
(full-uri (build-uri (uri-scheme server-uri)
#:userinfo (uri-userinfo server-uri)
#:host (uri-host server-uri)
#:port (uri-port server-uri)
#:path (string-append
"/"
(encode-and-join-uri-path
(append
(split-and-decode-uri-path (uri-path server-uri))
(split-and-decode-uri-path
(uri-path uri))))))))
(and authz dpop
(eq? (car authz) 'dpop)
(with-exception-handler
(lambda (error)
(if (exception-with-message? error)
(format (current-error-port)
(G_ "~a: authentication failure: ~a\n")
(date->string current-time)
(exception-message error))
(format (current-error-port)
(G_ "~a: authentication failure\n")
(date->string current-time)))
#f)
(lambda ()
;; Sometimes the access is the cadr as a symbol,
;; sometimes it is the cdr as a string. It depends
;; whether the response has been written and read,
;; or preserved as a guile object.
(let* ((lit-access-token
(match authz
;; That’s when the request is parsed:
(('dpop (? symbol? symbol-value))
(symbol->string symbol-value))
;; That’s when it’s not:
(('dpop . (? string? string-value))
string-value)))
(access-token
(decode lit-access-token))
(cnf/jkt (cnf/jkt access-token))
(dpop-proof
(decode dpop
#:method method
#:uri full-uri
#:cnf/check cnf/jkt
#:access-token lit-access-token)))
(let ((subject (webid access-token))
(issuer (iss access-token)))
(confirm-provider subject issuer)
subject)))
#:unwind? #t)))))))
(define (handle-errors f g)
(call/ec
(lambda (do-return)
(define (return . args)
(apply do-return args))
(with-exception-handler
(lambda (error)
(g return error))
(lambda ()
(f return))
#:unwind? #t))))
(define (nonrdf-or-turtle server-uri request request-body)
;; If the request is an exotic RDF serialization
;; format, we want to convert it to Turtle,
;; otherwise we will consider it non-rdf.
(convert '(text/turtle */*)
server-uri
(uri-path (request-uri request))
(request-content-type request)
request-body))
(define (serve-get return path if-match if-none-match content-type content etag headers user)
(define (respond-normal)
(return
(build-response
#:headers headers)
content
user))
(if if-match
;; If the precondition failed, then we should respond with 412
(with-exception-handler
(lambda (error)
(unless (precondition-failed? error)
(raise-exception error))
(return
(build-response
#:code 412
#:reason-phrase (W_ "reason-phrase|Precondition Failed"))
#f
user))
(lambda ()
(check-precondition path if-match if-none-match etag)
(respond-normal)))
;; If the precondition succeeds (if-none-match is effectively
;; invalid), we return 200
(with-exception-handler
(lambda (error)
(unless (precondition-failed? error)
(raise-exception error))
(return
(build-response
#:code 304
#:reason-phrase (W_ "reason-phrase|Not Modified")
#:headers
(filter
(lambda (h)
(case (car h)
((cache-control content-location date etag expires vary)
#t)
(else #f)))
headers))
#f
user))
(lambda ()
(when if-none-match
(check-precondition path if-match if-none-match etag))
(respond-normal)))))
(define* (make-resource-server
#:key
(server-uri #f)
(owner #f)
(authenticator #f))
(unless owner
(fail (G_ "The owner is not defined.")))
(declare-link-header!)
(unless authenticator
(set! authenticator
(make-authenticator
#:server-uri server-uri)))
(lambda (request request-body)
(parameterize ((p:current-date ((p:current-date))) ;; Fix the date
(web-locale request))
(let ((user (authenticator request request-body)))
(handle-errors
(lambda (return)
(let ((method (request-method request)))
(case method
((GET HEAD OPTIONS)
(receive (headers content)
(ldp:read server-uri owner user
(uri-path (request-uri request)))
(let ((true-content-type
(car (assq-ref headers 'content-type)))
(other-headers
(filter
(lambda (h)
(not (eq? (car h) 'content-type)))
headers)))
(receive (negociated-content-type
negociated-content)
(convert (request-accept request #f)
server-uri
(uri-path (request-uri request))
true-content-type
content)
(serve-get
return
(uri-path (request-uri request))
(request-if-match request)
(request-if-none-match request)
negociated-content-type
negociated-content
(car (assq-ref headers 'etag))
(cons `(content-type ,negociated-content-type)
other-headers)
user)))))
((PUT)
(receive (content-type content)
(nonrdf-or-turtle server-uri request request-body)
(return
(build-response
#:headers
`((etag . (,(ldp:update server-uri owner user
(uri-path (request-uri request))
(request-if-match request)
(request-if-none-match request)
content-type
content)
. #f))))
""
user)))
((POST)
(receive (content-type content)
(nonrdf-or-turtle server-uri request request-body)
(let ((types
(map target-iri
(filter
(lambda (link)
(equal? (relation-type link) "type"))
(request-links request)))))
(return
(build-response
#:code 201 #:reason-phrase (W_ "reason-phrase|Created")
#:headers
`((location . ,(ldp:create server-uri owner user
(uri-path (request-uri request))
types
(assq-ref (request-headers request) 'slug)
content-type
content))))
""
user))))
((DELETE)
(ldp:delete server-uri owner user
(uri-path (request-uri request))
(request-if-match request)
(request-if-none-match request))
(return
(build-response)
""
user)))))
(lambda (return error)
(if (wac:cannot-fetch-group? error)
(if (exception-with-message? error)
(format (current-error-port)
(G_ "~a: ignoring a group that cannot be fetched: ~a\n")
(date->string ((p:current-date)))
(exception-message error))
(format (current-error-port)
(G_ "~a: ignoring a group that cannot be fetched\n")
(date->string ((p:current-date)))))
(cond
((ldp:uri-slash-semantics-error? error)
(return
(build-response
#:code 301
#:reason-phrase (W_ "reason-phrase|Found")
#:headers
`((location
. ,(build-uri
(uri-scheme server-uri)
#:userinfo (uri-userinfo server-uri)
#:host (uri-host server-uri)
#:port (uri-port server-uri)
#:path (ldp:uri-slash-semantics-error-existing error)))))
#f
user))
((or (ldp:path-not-found? error)
(ldp:auxiliary-resource-absent? error)
(wac:forbidden? error))
(if user
;; That’s a forbidden
(return
(build-response #:code 403 #:reason-phrase (W_ "reason-phrase|Forbidden"))
#f
user)
(return
(build-response #:code 401 #:reason-phrase (W_ "reason-phrase|Unauthorized")
#:headers `((www-authenticate . ((DPoP)))))
#f
user)))
((ldp:cannot-delete-root? error)
(return
(build-response
#:code 405
#:reason-phrase (W_ "reason-phrase|Method Not Allowed"))
#f
user))
((or (ldp:container-not-empty? error)
(ldp:incorrect-containment-triples? error)
(ldp:path-is-auxiliary? error))
(return
(build-response
#:code 409
#:reason-phrase (W_ "reason-phrase|Conflict"))
#f
user))
((ldp:unsupported-media-type? error)
(return
(build-response
#:code 415
#:reason-phrase (W_ "reason-phrase|Unsupported Media Type"))
#f
user))
((precondition-failed? error)
(return
(build-response
#:code 412
#:reason-phrase (W_ "reason-phrase|Precondition Failed"))
#f
user))
((not-acceptable? error)
(return
(build-response
#:code 406
#:reason-phrase (W_ "reason-phrase|Not Acceptable"))
#f
user))
(else
(raise-exception error))))))))))