;; 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 <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 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 <authorization-code>
                           jwk
                           #:webid subject
                           #:client-id client-id))
                    (mf (make <client-manifest>
                          #: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)))))))