;; webid-oidc, 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 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 client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs))

(define (verify-password encrypted-password password)
  (let ((c (crypt password encrypted-password)))
    (string=? c encrypted-password)))

(define*-public (make-authorization-endpoint subject encrypted-password alg jwk validity
                                             #:key
                                             (http-get http-get))
  (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 (lambda (x) (parse-arg x #f)) query-parts))
           (form-args
            (if (and
                 (request-content-type request)
                 (eq? (car (request-content-type request))
                      'application/x-www-form-urlencoded))
                (let ((parts (string-split request-body #\&)))
                  (map (lambda (x) (parse-arg x #t)) parts))
                '()))
           (accept-language
            (sort (request-accept-language request)
                  (lambda (x y) (>= (car x) (car y)))))
           (locale (if (null? accept-language)
                       "C"
                       (cdar accept-language))))
      (let ((client-id (assoc-ref get-args "client_id"))
            (redirect-uri (assoc-ref get-args "redirect_uri"))
            (password (assoc-ref form-args "password"))
            (state (assoc-ref get-args "state")))
        (when client-id
          (set! client-id (car client-id)))
        (when redirect-uri
          (set! redirect-uri (string->uri (car redirect-uri))))
        (when password
          (set! password (car password)))
        (when state
          (set! state (car state)))
        (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* ((current-time ((p:current-date))) ;; current-date is a thunk parameter
                     (current-sec
                      (time-second (date->time-utc current-time)))
                     (exp-sec (+ current-sec validity))
                     (exp (time-utc->date (make-time time-utc 0 exp-sec)))
                     (code (issue-authorization-code alg jwk exp subject client-id)))
                (let ((mf (get-client-manifest (string->uri client-id)
                                               #:http-get http-get)))
                  (client-manifest-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
                                   (string->uri client-id)
                                   uri))))))
            #:unwind? #t))
         (else
          (authorization-page locale
                              (not (and password
                                        (verify-password encrypted-password password)))
                              client-id
                              uri)))))))