;; disfluid, implementation of the Solid specification
;; Copyright (C) 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 server endpoint client)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc provider-confirmation)
  #:use-module (webid-oidc client-manifest)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (web client)
  #: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)
  #:use-module (srfi srfi-26)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:re-export
  (
   client-id
   redirect-uris
   )
  #:export
  (
   <client-id>
   client-name
   client-uri
   grant-types
   response-types

   <redirect-uri>
   ))

(define-class <client-id> (<endpoint> <client-manifest>)
  (client-name #:init-keyword #:client-name #:getter client-name)
  (client-uri #:init-keyword #:client-uri #:getter client-uri)
  (grant-types #:init-keyword #:grant-types #:getter grant-types)
  (response-types #:init-keyword #:response-types #:getter response-types)
  #:module-name '(webid-oidc server endpoint client))

(define-method (initialize (c <client-id>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((client-name (G_ "Example Solid Application"))
    (client-uri (string->uri "https://disfluid.planete-kraus.eu"))
    (grant-types '(refresh_token authorization_code))
    (response-types '(code)))
   (match client-uri
     ((? string? (= string->uri (? uri? client-uri)))
      (slot-set! c 'client-uri client-uri))
     ((? uri?)
      #t)
     (else
      (scm-error 'wrong-type-arg "make <client-id>"
                 (G_ "#:client-uri should be an URI")
                 '()
                 (list client-uri))))
   (let ((fix-symbol-list
          (lambda (items what)
            (let fix ((values items)
                      (fixed '())
                      (index 0))
              (match values
                ((? vector? x)
                 (fix (vector->list x) fixed index))
                (()
                 (slot-set! c what (reverse fixed)))
                (((or (? string? (= string->symbol value))
                      (? symbol? value))
                  values ...)
                 (fix values `(,value @fixed) (+ index 1)))
                ((wrong _ ...)
                 (scm-error 'wrong-type-arg "make <client-id>"
                            (format #f (G_ "#:~a element ~a should be a string or a symbol")
                                    what index)
                            '()
                            (list wrong)))
                (else
                 (scm-error 'wrong-type-arg "make <client-id>"
                            (format #f (G_ "#:~a should be a list")
                                    what)
                            '()
                            (list values))))))))
     (fix-symbol-list grant-types 'grant-types)
     (fix-symbol-list response-types 'response-types))))

(define-method (handle (endpoint <client-id>) request request-body)
  (receive (response response-body) (serve endpoint #f)
    (let ((if-none-match (request-if-none-match request))
          (etag (response-etag response)))
      (if (and (list? if-none-match)
               etag
               (member (car etag) (map car if-none-match)))
          (values
           (build-response
            #:code 304
            #:reason-phrase (W_ "reason-phrase|Not Modified")
            #:headers `((content-type application/ld+json)
                        (etag . ,etag)))
           #f
           '())
          (values response response-body '())))))

(define-class <redirect-uri> (<endpoint>))

(define-method (handle (endpoint <redirect-uri>) request request-body)
  (format (current-error-port) "Handling a redirect URI… ~a\n" (uri->string (request-uri request)))
  (let ((query-args
         (apply
          append
          (map
           (lambda (key=value)
             (match (map uri-decode (string-split key=value #\=))
               ((key value)
                `((,(string->symbol key) . ,value)))
               (else '())))
           (string-split (uri-query (request-uri request)) #\&)))))
    (format (current-error-port) "Query args: ~s\n" query-args)
    (let ((code (assq-ref query-args 'code)))
      (format (current-error-port) "Code: ~s\n" code)
      (if code
          (values
           (build-response
            #:headers `((content-type application/xhtml+xml)))
           (call-with-output-string
             (cute sxml->xml
                   `(*TOP*
                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                              (xml:lang ,(W_ "xml-lang|en")))
                           (head
                            (title ,(W_ "page-title|Authorization")))
                           (body
                            (p ,(W_ "You have been authorized. Please paste the following code in the application:"))
                            (p (strong ,code)))))
                   <>))
           '())
          ;; No code:
          (raise-exception
           (make-exception
            (make-web-exception 400 (W_ "reason-phrase|Invalid Request"))
            (make-user-message
             `(p ,(W_ "This page should obtain a code from your identity provider, but none has been provided.")))))))))