path: root/src/scm/webid-oidc/example-app.scm

;; 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 account:)
  #:use-module ((webid-oidc cache) #:prefix cache:)
  #: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 (web uri)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web server)
  #:use-module (web http)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-1)
  #: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 (ice-9 exceptions)
  #:use-module (ice-9 readline)
  #:use-module (sxml simple)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:declarative? #t
  #:export (main))

(define <client:client> client:<client>)
(define <account:account> account:<account>)

(define-class <app-state> ()
  (account #:init-keyword #:account #:getter app-state-account)
  (unused-accounts #:init-keyword #:unused-accounts #:getter app-state-unused-accounts)
  (uri #:init-keyword #:uri #:getter app-state-uri)
  (method #:init-keyword #:method #:getter app-state-method #:init-value 'GET)
  (headers #:init-keyword #:headers #:getter app-state-headers #:init-value '()))

(define-method (equal? (a <app-state>) (b <app-state>))
  ;; This method will let us know if an action is a re-do or a novel
  ;; update
  (and (equal? (app-state-account a) (app-state-account b))
       (equal? (app-state-unused-accounts a) (app-state-unused-accounts b))
       (equal? (app-state-uri a) (app-state-uri b))
       (eq? (app-state-method a) (app-state-method b))
       (equal? (app-state-headers a) (app-state-headers b))))

(define-method (add-account (app <app-state>) (account <account:account>))
  (let ((ret (shallow-clone app)))
    ;; If we have already selected an account, make it unused,
    ;; otherwise select it as default.
    (if (app-state-account ret)
        (slot-set! ret 'unused-accounts
                   `(,account ,@(app-state-unused-accounts app)))
        (slot-set! ret 'account account))
    ret))

(define-method (enumerate-accounts (app <app-state>))
  (let construct ((all-accounts `(,(app-state-account app)
                                  ,@(app-state-unused-accounts app)))
                  (i 1)
                  (constructed '()))
    (match all-accounts
      (()
       (reverse constructed))
      ((next rest ...)
       (construct rest (+ i 1) `((,i . ,next) ,@constructed))))))

(define-method (account-summary (account <account:account>))
  (let ((subject (account:subject account))
        (issuer (account:issuer account))
        (access-token (account:access-token account))
        (refresh-token (account:refresh-token account)))
    (cond
     ((and access-token refresh-token)
      (format #f (G_ "~a (issued by ~a): no interaction required")
              (uri->string subject) (uri->string issuer)))
     (refresh-token
      (format #f (G_ "~a (issued by ~a): offline but accessible")
              (uri->string subject) (uri->string issuer)))
     (access-token
      (format #f (G_ "~a (issued by ~a): online")
              (uri->string subject) (uri->string issuer)))
     (else
      (format #f (G_ "~a (issued by ~a): inaccessible")
              (uri->string subject) (uri->string issuer))))))

(define-method (choose-account (app <app-state>) (i <integer>))
  (let ((ret (shallow-clone app))
        (all-accounts (enumerate-accounts app)))
    (let find-the-account ((accounts all-accounts)
                           (past '()))
      (match accounts
        (()
         (raise-exception
          (make-exception
           (make-exception-with-message
            (format #f (G_ "Your choice ~a does not exist.\n") i)))))
        ((((? (cute eqv? <> i)) . hd) tl ...)
         (begin
           (slot-set! ret 'account hd)
           (slot-set! ret 'unused-accounts
                      (let ((tl (map (match-lambda ((_ . account) account)) tl)))
                        (append-reverse past tl)))))
        (((_ . hd) tl ...)
         (find-the-account tl `(,hd ,@past)))))
    ret))

(define-method (set-uri (app <app-state>) uri)
  (let ((ret (shallow-clone app)))
    (when (string? uri)
      (set! uri (string->uri uri)))
    (unless (uri? uri)
      (raise-exception
       (make-exception
        (make-exception-with-message (G_ "Your choice is not a valid URI.\n")))))
    (slot-set! ret 'uri uri)
    ret))

(define-method (set-method (app <app-state>) method)
  (with-exception-handler
      (lambda (exn)
        (raise-exception
         (make-exception
          (make-exception-with-message (G_ "This is not a valid HTTP method.\n")))))
    (lambda ()
      (let ((ret (shallow-clone app)))
        (slot-set! ret 'method (string->symbol method))
        ret))))

(define-method (clear-headers (app <app-state>))
  (let ((ret (shallow-clone app)))
    (slot-set! ret 'headers '())
    ret))

(define-method (add-header (app <app-state>) (header <string>) (value <string>))
  (with-exception-handler
      (lambda (exn)
        (raise-exception
         (make-exception
          (make-exception-with-message (G_ "This is not a valid value for this header.\n")))))
    (lambda ()
      (let ((ret (shallow-clone app))
            (new-header (parse-header (string->symbol header) value)))
        (slot-set! ret 'headers
                   `((,(string->symbol header) . ,new-header)
                     ,@(app-state-headers ret)))
        ret))))

(define-class <undoable-app-state> ()
  (previous-states
   #:init-keyword #:previous-states
   #:getter app-previous-states
   #:init-value '())
  (undone-states
   #:init-keyword #:undone-states
   #:getter app-undone-states
   #:init-value '()))

(define-method (current-state (app <undoable-app-state>))
  (match (app-previous-states app)
    ((state _ ...)
     state)
    (else
     (make <app-state> #:account #f #:unused-accounts '() #:uri #f))))

(define-method (can-undo? (app <undoable-app-state>))
  (not (null? (app-previous-states app))))

(define-method (can-redo? (app <undoable-app-state>))
  (not (null? (app-undone-states app))))

(define-method (undo (app <undoable-app-state>))
  (let ((ret (shallow-clone app)))
    (match (app-previous-states ret)
      (()
       (raise-exception
        (make-exception
         (make-exception-with-message (G_ "Nothing to undo.\n")))))
      ((undone other-done ...)
       (slot-set! ret 'previous-states other-done)
       (slot-set! ret 'undone-states `(,undone ,@(app-undone-states ret)))))
    ret))

(define-method (redo (app <undoable-app-state>))
  (let ((ret (shallow-clone app)))
    (match (app-undone-states ret)
      (()
       (raise-exception
        (make-exception
         (make-exception-with-message (G_ "Nothing to redo.\n")))))
      ((redone other-undone ...)
       (slot-set! ret 'previous-states `(,redone ,@(app-previous-states ret)))
       (slot-set! ret 'undone-states other-undone)))
    ret))

(define-method (push-state (app <undoable-app-state>) (state <app-state>))
  ;; Maybe it’s a redo
  (match (app-undone-states app)
    (((? (cute equal? <> state)) _ ...)
     ;; This is a redo
     (redo app))
    (else
     ;; This is not a redo
     (let ((ret (shallow-clone app)))
       (slot-set! ret 'previous-states `(,state ,@(app-previous-states ret)))
       (slot-set! ret 'undone-states '())
       ret))))

(define-method (add-account (app <undoable-app-state>) (account <account:account>))
  (push-state
   app
   (add-account (current-state app) account)))

(define-method (enumerate-accounts (app <undoable-app-state>))
  (enumerate-accounts (current-state app)))

(define-method (choose-account (app <undoable-app-state>) (i <integer>))
  (push-state app (choose-account (current-state app) i)))

(define-method (set-uri (app <undoable-app-state>) (uri <string>))
  (push-state app (set-uri (current-state app) uri)))

(define-method (set-method (app <undoable-app-state>) (method <string>))
  (push-state app (set-method (current-state app) method)))

(define-method (clear-headers (app <undoable-app-state>))
  (push-state app (clear-headers (current-state app))))

(define-method (add-header (app <undoable-app-state>) (header <string>) (value <string>))
  (push-state app (add-header (current-state app) header value)))

(define (with-sigint-handler handler f)
  ;; I don’t know how to re-install the previous sigaction
  (dynamic-wind
    (lambda ()
      (sigaction SIGINT
        (lambda (sig)
          (handler))))
    f
    (lambda ()
      (sigaction SIGINT #f))))

(define (main)
  (setvbuf (current-output-port) 'none)
  (setvbuf (current-error-port) 'none)
  (setlocale LC_ALL "")
  (bindtextdomain cfg:package cfg:localedir)
  (textdomain cfg:package)
  (define add-account-command
    (G_ "Example app command|add-account"))
  (define choose-account-command
    (G_ "Example app command|choose-account"))
  (define set-uri-command
    (G_ "Example app command|set-uri"))
  (define set-method-command
    (G_ "Example app command|set-method"))
  (define view-headers-command
    (G_ "Example app command|view-headers"))
  (define clear-headers-command
    (G_ "Example app command|clear-headers"))
  (define add-header-command
    (G_ "Example app command|add-header"))
  (define ok-command
    (G_ "Example app command|ok"))
  (define undo-command
    (G_ "Example app command|undo"))
  (define redo-command
    (G_ "Example app command|redo"))
  (parameterize
      ((client:client
        (make <client:client>
          #:client-id
          "https://webid-oidc-demo.planete-kraus.eu/example-application#id"
          #:redirect-uri
          "https://webid-oidc-demo.planete-kraus.eu/authorized"))
       (client:authorization-process
        (lambda* (uri #:key reason)
          (format (current-error-port) (G_ "Your authorization is required: ~a, please visit: ~a\n")
                  reason
                  (uri->string uri))
          (format (current-error-port) (G_ "Then, paste the authorization code you get:\n"))
          (read-line (current-input-port) 'trim)))
       (client:authorization-state #f))
    (cache:use-cache
     (lambda ()
       (let menu ((state (make <undoable-app-state>)))
         (format #t (G_ "Account: ~a
URI: ~a
Method: ~a
Headers: ~a

Available commands:
  - ~a: add an account
  - ~a: change the account
  - ~a: change the URI
  - ~a: change the method
  - ~a: view all headers
  - ~a: clear all the headers
  - ~a: add a new header
  - ~a: perform the request.

")
                 (let ((acct (app-state-account (current-state state))))
                   (if acct
                       (account-summary acct)
                       (G_ "Account:|unset")))
                 (let ((uri (app-state-uri (current-state state))))
                   (if uri
                       (uri->string uri)
                       (G_ "URI:|unset")))
                 (let ((method (app-state-method (current-state state))))
                   (if method
                       (symbol->string method)
                       (G_ "Method:|unset")))
                 (let ((headers (app-state-headers (current-state state))))
                   (if (null? headers)
                       (G_ "Headers:|none")
                       (string-join
                        (map (match-lambda ((header . _) (symbol->string header)))
                             headers)
                        (G_ "list separator|, "))))
                 add-account-command
                 choose-account-command
                 set-uri-command
                 set-method-command
                 view-headers-command
                 clear-headers-command
                 add-header-command
                 ok-command)
         (when (can-undo? state)
           (format #t (G_ "You can undo your last command with \"~a\".\n") undo-command))
         (when (can-redo? state)
           (format #t (G_ "You can re-apply your last undone command with \"~a\".\n") redo-command))
         (let ((command (readline (G_ "Readline prompt|Command: "))))
           (if (eof-object? command)
               (exit 0)
               (with-exception-handler
                   (lambda (exn)
                     (if (exception-with-message? exn)
                         (begin
                           (format #t (G_ "An error happened: ~a.\n")
                                   (exception-message exn))
                           (menu state))
                         (raise-exception exn)))
                 (lambda ()
                   (cond
                    ((equal? command add-account-command)
                     (let ((identity-provider
                            (with-sigint-handler
                             (lambda ()
                               (menu state))
                             (lambda ()
                               (readline (G_ "Please enter your identity provider: "))))))
                       (menu (add-account state (make <account:account> #:issuer identity-provider)))))
                    ((equal? command choose-account-command)
                     (let ((accounts (enumerate-accounts state)))
                       (if (null? accounts)
                           (begin
                             (format #t (G_ "You don’t have other accounts available. Please add one with \"add-account\".\n"))
                             (menu state))
                           (begin
                             (let enumerate-accounts ((accounts accounts))
                               (match accounts
                                 (((i . account) rest ...)
                                  (format #t (G_ "- ~a: ~a\n") i (account-summary account))
                                  (enumerate-accounts rest))
                                 (() #t)))
                             (with-sigint-handler
                              (lambda ()
                                (menu state))
                              (lambda ()
                                (let ((choice (string->number
                                               (readline (format #f (G_ "[1-~a] ")
                                                                 (length accounts))))))
                                  (menu (choose-account state choice)))))))))
                    ((equal? command set-uri-command)
                     (with-sigint-handler
                      (lambda ()
                        (menu state))
                      (lambda ()
                        (menu (set-uri state (readline (G_ "Visit this URI: ")))))))
                    ((equal? command set-method-command)
                     (with-sigint-handler
                      (lambda ()
                        (menu state))
                      (lambda ()
                        (let ((method (readline (G_ "Use this HTTP method [GET]: "))))
                          (when (equal? method "")
                            (set! method "GET"))
                          (menu (set-method state method))))))
                    ((equal? command view-headers-command)
                     (write-headers (app-state-headers (current-state state))
                                    (current-output-port))
                     (newline)
                     (menu state))
                    ((equal? command clear-headers-command)
                     (menu (clear-headers state)))
                    ((equal? command add-header-command)
                     (with-sigint-handler
                      (lambda ()
                        (menu state))
                      (lambda ()
                        (let ((header (string-downcase (readline (G_ "Which header? ")))))
                          (let ((value
                                 (readline
                                  (format #f (G_ "Which header value for ~a? ")
                                          header))))
                            (menu (add-header state header value)))))))
                    ((equal? command ok-command)
                     (receive (account uri)
                         (let ((state (current-state state)))
                           (values
                            (app-state-account state)
                            (app-state-uri state)))
                       (if (and account uri)
                           (receive (account response body)
                               (client:request (app-state-account (current-state state))
                                               (app-state-uri (current-state state))
                                               #:method (app-state-method (current-state state))
                                               #:headers (app-state-headers (current-state state)))
                             (let ((ready-to-write-body
                                    (write-response response (current-output-port))))
                               (unless (response-must-not-include-body? ready-to-write-body)
                                 (write-response-body ready-to-write-body
                                                      (if (string? body)
                                                          (string->utf8 body)
                                                          body)))
                               (newline)))
                           (format #t (G_ "Please define an account and the URI.\n")))
                       (menu state)))
                    ((equal? command undo-command)
                     (menu (undo state)))
                    ((equal? command redo-command)
                     (menu (redo state)))
                    (else
                     (format #t (G_ "I don’t know that command.\n"))
                     (menu state))))))))))))