;; 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 .
(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 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 (web uri)
#:use-module (web client)
#: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:)
(define account:)
(define-class ()
(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 ) (b ))
;; 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 ) (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 ))
(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 ))
(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 ) (i ))
(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 ) 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 ) 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 ))
(let ((ret (shallow-clone app)))
(slot-set! ret 'headers '())
ret))
(define-method (add-header (app ) (header ) (value ))
(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 ()
(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 ))
(match (app-previous-states app)
((state _ ...)
state)
(else
(make #:account #f #:unused-accounts '() #:uri #f))))
(define-method (can-undo? (app ))
(not (null? (app-previous-states app))))
(define-method (can-redo? (app ))
(not (null? (app-undone-states app))))
(define-method (undo (app ))
(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 ))
(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 ) (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 ) (account ))
(push-state
app
(add-account (current-state app) account)))
(define-method (enumerate-accounts (app ))
(enumerate-accounts (current-state app)))
(define-method (choose-account (app ) (i ))
(push-state app (choose-account (current-state app) i)))
(define-method (set-uri (app ) (uri ))
(push-state app (set-uri (current-state app) uri)))
(define-method (set-method (app ) (method ))
(push-state app (set-method (current-state app) method)))
(define-method (clear-headers (app ))
(push-state app (clear-headers (current-state app))))
(define-method (add-header (app ) (header ) (value ))
(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-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 issuer)
(format (current-error-port) (G_ "To log in on ~a, please visit: ~a\n")
(uri->string issuer)
(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)
(client:anonymous-http-request
(let ((default-http-get-with-cache (cache:with-cache)))
(lambda* (uri . all-args)
(let try-get-with-cache ((args all-args)
(args-for-get '()))
(match args
(()
(apply default-http-get-with-cache uri (reverse args-for-get)))
((#:headers arg other-args ...)
(try-get-with-cache other-args `(,arg #:headers ,@args-for-get)))
((#:method 'GET other-args ...)
(try-get-with-cache other-args args-for-get))
(else
(apply http-request uri all-args))))))))
(let menu ((state (make )))
(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 #: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))))))))))