;; 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)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc cache) #:prefix cache:)
  #:use-module (webid-oidc dpop-proof)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module (web uri)
  #:use-module (web client)
  #: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 (ice-9 i18n)
  #: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 (sxml simple)
  #:use-module (rnrs bytevectors))

(define (G_ text)
  (let ((out (gettext text)))
    (if (string=? out text)
        ;; No translation, disambiguate
        (car (reverse (string-split text #\|)))
        out)))

(define (enumerate-profiles profiles)
  (define (aux i)
    (when (< i (vector-length profiles))
      (let ((prof (vector-ref profiles i)))
        (format #t (G_ "~a.\t~a, certified by ~a;\n")
                (+ i 1)
                (uri->string (car prof))
                (uri->string (cadr prof))))
      (aux (+ i 1))))
  (aux 0))

(define (enumerate-providers providers)
  (define (aux i)
    (when (< i (vector-length providers))
      (let ((prov (vector-ref providers i)))
        (format #t (G_ "~a – ~a\n")
                (+ i 1)
                (prov)))
      (aux (+ i 1))))
  (aux 0))

(define (select-choice mini maxi question)
  (format #t "~a" question)
  (let* ((line
          (read-line (current-input-port) 'trim))
         (number (false-if-exception (string->number line))))
    (cond
     ((eof-object? line)
      (exit 0))
     ((and (integer? number)
           (>= number mini)
           (<= number maxi))
      number)
     (else
      (format #t (G_ "I’m expecting a number between ~a and ~a.\n")
              mini maxi)
      (select-choice mini maxi question)))))

(define cache-http-get (cache:with-cache))

(define (inner-main-loop http-request)
  (format #t (G_ "Please enter an URI to GET: "))
  (let ((line (read-line (current-input-port) 'trim)))
    (unless (eof-object? line)
      (let ((uri (string->uri line)))
        (receive (response response-body)
            (http-request uri)
          (let ((write-body
                 (write-response response (current-output-port))))
            (when (string? response-body)
              (set! response-body (string->utf8 response-body)))
            (when response-body
              (write-response-body write-body response-body)))))
      (inner-main-loop http-request))))

(define (main-loop id-token access-token key)
  (let ((my-http-request
         (make-client id-token access-token key
                      #:http-request
                      (lambda args
                        (format (current-error-port) (G_ "Sending a request: ~s\n") args)
                        (apply http-request args)))))
    (inner-main-loop my-http-request)))

(define-public (inner-main)
  (setlocale LC_ALL "")
  (bindtextdomain cfg:package cfg:localedir)
  (textdomain cfg:package)
  (let ((version-sym
         (string->symbol (G_ "command-line|version")))
        (help-sym
         (string->symbol (G_ "comand-line|help"))))
    (let ((options
           (let ((option-spec
                  `((,version-sym (single-char #\v) (value #f))
                    (,help-sym (single-char #\h) (value #f)))))
             (getopt-long (command-line) option-spec))))
      (cond
       ((option-ref options help-sym #f)
        (format #t (G_ "Usage: ~a [OPTIONS]...

Demonstrate a webid-oidc application.

Options:
  -h, --~a:
      display this help message and exit.
  -v, --~a:
      display the version information (~a) and exit.

Environment variables:

  LANG: set the locale. Currently ~a.

  XDG_CACHE_HOME: where the seed for the key generator is
stored. Currently ~a.

  XDG_DATA_HOME: where the login credentials are stored. Currently ~a.

  HOME: to compute a default value for XDG_CACHE_HOME and
XDG_DATA_HOME, if missing. Currently ~a.

If you find a bug, send a report to ~a.
")
                (car (command-line))
                help-sym version-sym
                cfg:version
                (or (getenv "LANG") "")
                (or (getenv "XDG_CACHE_HOME") "")
                (or (getenv "XDG_DATA_HOME") "")
                (or (getenv "HOME") "")
                cfg:package-bugreport))
       ((option-ref options version-sym #f)
        (format #t (G_ "~a version ~a\n")
                cfg:package cfg:version))
       (else
        (let ((profiles (list->vector (list-profiles))))
          (format #t (G_ "First, let’s log in. Here are your options:\n"))
          (enumerate-profiles profiles)
          (format #t (G_ "0.\tLog in with a different identity.\n"))
          (let ((i-profile
                 (select-choice
                  0
                  (vector-length profiles)
                  (G_ "Please indicate your choice number: "))))
            (receive (id-token access-token key)
                (if (eqv? i-profile 0)
                    (setup
                     (lambda ()
                       (format #t (G_ "Please enter your webid, or identity server: "))
                       (read-line (current-input-port) 'trim))
                     (lambda (providers)
                       (cond
                        ((null? providers)
                         (error "No, this cannot happen."))
                        ((null? (cdr providers))
                         (car providers))
                        (else
                         (set! providers (list->vector providers))
                         (format #t (G_ "There are different possible identity providers for your webid:\n"))
                         (enumerate-providers providers)
                         (let ((i-provider
                                (select-choice 1 (- (vector-length providers) 1)
                                               (G_ "Please indicate your choice number: "))))
                           (vector-ref providers i-provider)))))
                     (lambda (uri)
                       (format #t (G_ "Please visit the following URI with a web browser:\n~a\n")
                               (uri->string uri))
                       (format #t (G_ "Please paste your authorization code: "))
                       (read-line (current-input-port) 'trim))
                     #:client-id "https://webid-oidc-demo.planete-kraus.eu/example-application#id"
                     #:redirect-uri "https://webid-oidc-demo.planete-kraus.eu/authorized"
                     #:http-get cache-http-get)
                    (let ((profile (vector-ref profiles (- i-profile 1))))
                      (let ((webid (car profile))
                            (issuer (cadr profile))
                            (refresh-token (caddr profile))
                            (key (cadddr profile)))
                        (login webid issuer refresh-token key #:http-get cache-http-get))))
              (format #t (G_ "Log in success. Keep this identity token for yourself:

~a

Now, you can do authenticated request by presenting the following access token:

~a

and signing DPoP proofs with the following key:

~a
")
                      (stubs:scm->json-string id-token #:pretty #t)
                      access-token
                      (stubs:scm->json-string key #:pretty #t))
              (main-loop id-token access-token key)))))))))

(define-public (main)
  (with-exception-handler
      (lambda (error)
        (format (current-error-port)
                (G_ "There was an error: ~a\n")
                (error->str error)))
    (lambda ()
      (inner-main))
    #:unwind? #t))