;; 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 authorization-endpoint)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc authorization-page)
#:use-module (webid-oidc jwk)
#:use-module (webid-oidc authorization-code)
#:use-module (webid-oidc client-manifest)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module (web uri)
#:use-module (web request)
#:use-module (web response)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module (ice-9 match)
#:use-module (oop goops)
#:declarative? #t
#:duplicates (merge-generics)
#:export
(
make-authorization-endpoint
))
(define (verify-password encrypted-password password)
(let ((c (crypt password encrypted-password)))
(string=? c encrypted-password)))
(define (make-authorization-endpoint subject encrypted-password jwk)
(define (parse-arg x decode-plus-to-space?)
(map (lambda (x) (uri-decode
x
#:decode-plus-to-space? decode-plus-to-space?))
(string-split x #\=)))
(lambda* (request request-body)
(when (bytevector? request-body)
(set! request-body (utf8->string request-body)))
(let* ((uri (request-uri request))
(method (request-method request))
(query (uri-query uri))
(query-parts (if query
(string-split query #\&)
'()))
(get-args (map (cute parse-arg <> #f) query-parts))
(form-args
(match (request-content-type request)
((application/x-www-form-urlencoded . _)
(map (cute parse-arg <> #t)
(string-split request-body #\&)))
(else '())))
(accept-language
(sort (request-accept-language request)
(lambda (x y) (>= (car x) (car y)))))
(locale
(match accept-language
(((_ . lng) _ ...) lng)
(else "C"))))
(let ((client-id
(match (assoc-ref get-args "client_id")
(((? string->uri client-id) . _)
(string->uri client-id))
(else #f)))
(redirect-uri
(match (assoc-ref get-args "redirect_uri")
(((? string->uri redirect-uri) . _)
(string->uri redirect-uri))
(else #f)))
(password
(match (assoc-ref form-args "password")
((password . _)
password)
(else #f)))
(state
(match (assoc-ref get-args "state")
((state . _)
state)
(else #f))))
(cond
((not client-id)
(error-no-client-id locale))
((not redirect-uri)
(error-no-redirect-uri locale))
((and (eq? method 'POST)
(string? password)
(verify-password encrypted-password password))
(with-exception-handler
(lambda (error)
(error-application locale error))
(lambda ()
(let ((code (issue
jwk
#:webid subject
#:client-id client-id))
(mf (make
#:client-id client-id)))
(check-redirect-uri mf redirect-uri)
(let ((query
(if state
(format #f "code=~a&state=~a"
(uri-encode code)
(uri-encode state))
(format #f "code=~a"
(uri-encode code)))))
(let ((uri
(build-uri 'https
#:userinfo (uri-userinfo redirect-uri)
#:host (uri-host redirect-uri)
#:port (uri-port redirect-uri)
#:path (uri-path redirect-uri)
#:query query)))
(redirection locale client-id uri)))))
#:unwind? #t))
(else
(authorization-page locale
(not (and password
(verify-password encrypted-password password)))
client-id
uri)))))))