;; 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 example-app)
  #:use-module ((webid-oidc client) #:prefix client:)
  #:use-module ((webid-oidc client accounts) #:prefix client:)
  #:use-module ((webid-oidc cache) #:prefix cache:)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc web-i18n)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module ((webid-oidc jwk) #:prefix jwk:)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web server)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 match)
  #:use-module (sxml simple)
  #:use-module (rnrs bytevectors)
  #:declarative? #t)

(define (main)
  (define (do-the-trick subject issuer)
    (client:request
     (client:make-client
      (string->uri
       "https://webid-oidc-demo.planete-kraus.eu/example-application#id")
      (jwk:generate-key #:n-size 2048)
      (string->uri
       "https://webid-oidc-demo.planete-kraus.eu/authorized"))
     subject issuer))
  (let ((accounts (list->vector (client:read-accounts))))
    (format #t (G_ "Main menu:\n"))
    (let enumerate-accounts ((i 0))
      (when (< i (vector-length accounts))
        (format #t (G_ "~a. Log in with ~a (issued by ~a): ~a
")
                (1+ i)
                (or (let ((subject (client:account-subject (vector-ref accounts i))))
                      (and subject (uri->string subject)))
                    (format #f (G_ "a new user")))
                (uri->string (client:account-issuer (vector-ref accounts i)))
                (if (client:account-subject (vector-ref accounts i))
                    (if (client:account-id-token (vector-ref accounts i))
                        (format #f (G_ "status|currently logged in"))
                        (if (client:account-refresh-token (vector-ref accounts i))
                            (format #f (G_ "status|offline (but accessible)"))
                            (format #f (G_ "status|offline (inaccessible)"))))
                    (format #f (G_ "status|not initialized yet"))))
        (enumerate-accounts (1+ i))))
    (format #t (G_ "Type a number to log in, prefix it with '-' to delete the account, or type + to create a new account.
"))
    (match (read-line (current-input-port) 'trim)
      ((? string?
          (= string->number
             (and (? integer? _)
                  (? (cute >= <> 1) _)
                  (? (cute <= <> (vector-length accounts)))
                  (= (cute - <> 1) choice))))
       (let ((account (vector-ref accounts choice)))
         (parameterize
             ((client:authorization-process
               ;; There’s a problem with guile continuable
               ;; exceptions: we can’t handle errors in a handler for
               ;; continuable exceptions. Until this is clarified, we
               ;; avoid continuable exceptions.
               (lambda* (uri #:key issuer)
                 (format (current-error-port) (G_ "Please visit: ~a\n") (uri->string uri))
                 (format (current-error-port) (G_ "Then, paste the authorization code you get:\n"))
                 (read-line (current-input-port) 'trim))))
           (with-exception-handler
               (lambda (error)
                 (cond
                  ((client:token-request-failed? error)
                   (format (current-error-port) (G_ "I could not negociate an access token.  ~a")
                           (exception-message error))
                   (main))
                  ((client:refresh-token-expired? error)
                   (format (current-error-port) (G_ "The refresh token has expired, it is not possible to use that account offline.\n"))
                   (main))
                  (else
                   (raise-exception error))))
             (lambda ()
               (format #t (G_ "Please enter an URI to GET:\n"))
               (let ((uri (string->uri (read-line (current-input-port) 'trim)))
                     (handler (do-the-trick (client:account-subject account)
                                            (client:account-issuer account))))
                 (receive (response response-body)
                     (handler (build-request uri) "")
                   (let ((ad-hoc-port (write-response response (current-output-port))))
                     (unless (response-must-not-include-body? response)
                       (when (string? response-body)
                         (set! response-body (string->utf8 response-body)))
                       (write-response-body ad-hoc-port response-body)))))
               (format #t "\n")
               (main))))))
      ((? string?
          (= string->number
             (and (? integer? _)
                  (= (cute - <>)
                     (and (? (cute >= <> 1) _)
                          (? (cute <= <> (vector-length accounts)) _)
                          (= (cute - <> 1) choice))))))
       ;; Delete
       (client:delete-account (vector-ref accounts choice))
       (main))
      ("+"
       ;; Create an account
       (format #t (G_ "Please type your identity provider:\n"))
       (let ((issuer (read-line (current-input-port) 'trim)))
         (when (and (string? issuer) (string->uri issuer))
           (client:save-account
            (client:make-account #f (string->uri issuer) #f #f #f #f))))
       (main))
      ((? eof-object? _)
       (exit 0))
      (else
       (main)))))

(main)