(define-module (webid-oidc client)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc provider-confirmation)
  #:use-module (webid-oidc oidc-configuration)
  #:use-module (webid-oidc oidc-id-token)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc jwk)
  #: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-19)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (sxml simple))

(define*-public (authorize host-or-webid
                           #:key
                           (client-id #f)
                           (redirect-uri #f)
                           (state #f)
                           (http-get http-get))
  (define cannot-be-webid #f)
  (define candidate-errors '())
  ;; host-or-webid can be: the host (as a string), an URI (as a string
  ;; or an URI). 3 differents things.
  (when (string? host-or-webid)
    ;; If it’s a string, it can be either a host name or a URI.
    (set! host-or-webid
          (catch #t
            (lambda ()
              (let ((urified (string->uri host-or-webid)))
                (if urified
                    urified
                    (error "It’s not a string representing an URI."))))
            (lambda error
              (build-uri 'https #:host host-or-webid)))))
  ;; client-id and redirect-uri are required, state must be a string.
  (when (string? client-id)
    (set! client-id (string->uri client-id)))
  (when (string? redirect-uri)
    (set! redirect-uri (string->uri redirect-uri)))
  (let ((host-candidates
         (with-exception-handler
             (lambda (why-not-webid)
               ;; try as an identity provider
               (set! cannot-be-webid why-not-webid)
               (build-uri 'https
                          #:userinfo (uri-userinfo host-or-webid)
                          #:host (uri-host host-or-webid)
                          #:port (uri-port host-or-webid)))
           (lambda ()
             (get-provider-confirmations host-or-webid #:http-get http-get))
           #:unwind? #t)))
    (let ((configurations
           (if cannot-be-webid
               (with-exception-handler
                   (lambda (why-not-identity-provider)
                     (raise-neither-identity-provider-nor-webid
                      host-or-webid
                      why-not-identity-provider
                      cannot-be-webid))
                 (lambda ()
                   (cons (uri->string host-candidates)
                         (get-oidc-configuration (uri-host host-candidates)
                                                 #:userinfo (uri-userinfo host-candidates)
                                                 #:port (uri-port host-candidates)
                                                 #:http-get http-get))))
               (filter
                (lambda (cfg) cfg)
                (map
                 (lambda (host)
                   (with-exception-handler
                       (lambda (cause)
                         (set! candidate-errors (acons host cause candidate-errors))
                         #f)
                     (lambda ()
                       (cons (uri->string host)
                             (get-oidc-configuration (uri-host host)
                                                     #:userinfo (uri-userinfo host)
                                                     #:port (uri-port host)
                                                     #:http-get http-get)))
                     #:unwind? #t))
                 host-candidates)))))
      (let ((authorization-endpoints
             (if cannot-be-webid
                 (with-exception-handler
                     (lambda (why-not-identity-provider)
                       (raise-neither-identity-provider-nor-webid
                        host-or-webid
                        why-not-identity-provider
                        cannot-be-webid))
                   (lambda ()
                     (let ((host (car configurations))
                           (cfg (cdr configurations)))
                       (cons host (oidc-configuration-authorization-endpoint cfg)))))
                 (map
                  (lambda (host/cfg)
                    (let ((host (car host/cfg))
                          (cfg (cdr host/cfg)))
                      (with-exception-handler
                          (lambda (cause)
                            (set! candidate-errors (acons (string->uri host) cause
                                                          candidate-errors)))
                        (lambda ()
                          (cons host
                                (oidc-configuration-authorization-endpoint cfg)))
                        #:unwind? #t)))
                  configurations))))
        (if cannot-be-webid
            (let ((host (car authorization-endpoints))
                  (authz (cdr authorization-endpoints)))
              (list
               (cons
                host
                (build-uri (uri-scheme authz)
                           #:userinfo (uri-userinfo authz)
                           #:host (uri-host authz)
                           #:port (uri-port authz)
                           #:path (uri-path authz)
                           #:query (format #f "client_id=~a&redirect_uri=~a~a"
                                           (uri-encode (uri->string client-id))
                                           (uri-encode (uri->string redirect-uri))
                                           (if state
                                               (format #f "&state=~a"
                                                       (uri-encode state))
                                               ""))))))
            (let ((final-candidates
                   (map
                    (lambda (host/authorization-endpoint)
                      (let ((host (car host/authorization-endpoint))
                            (authorization-endpoint (cdr host/authorization-endpoint)))
                        (cons
                         host
                         (build-uri (uri-scheme authorization-endpoint)
                                    #:userinfo (uri-userinfo authorization-endpoint)
                                    #:host (uri-host authorization-endpoint)
                                    #:port (uri-port authorization-endpoint)
                                    #:path (uri-path authorization-endpoint)
                                    #:query (format #f "client_id=~a&redirect_uri=~a~a"
                                                    (uri-encode (uri->string client-id))
                                                    (uri-encode (uri->string redirect-uri))
                                                    (if state
                                                        (format #f "&state=~a"
                                                                (uri-encode state))
                                                        ""))))))
                    authorization-endpoints)))
              (when (null? final-candidates)
                (raise-no-provider-candidates host-or-webid candidate-errors))
              final-candidates))))))

(define the-current-time current-time)

(define*-public (token host client-key
                       #:key
                       (authorization-code #f)
                       (refresh-token #f)
                       (http-get http-get)
                       (http-post http-post)
                       (current-time #f))
  (unless (or authorization-code refresh-token)
    (scm-error 'wrong-type-arg "token"
               "You need to either set #:authorization-code or #:refresh-token."
               '()
               (list authorization-code)))
  (unless current-time
    (set! current-time the-current-time))
  (when (thunk? current-time)
    (set! current-time (current-time)))
  (when (integer? current-time)
    (set! current-time (make-time time-utc 0 current-time)))
  (when (time? current-time)
    (set! current-time (time-utc->date current-time)))
  (let ((token-endpoint
         (oidc-configuration-token-endpoint
          (get-oidc-configuration host #:http-get http-get)))
        (grant-type
         (if authorization-code
             "authorization_code"
             "refresh_token")))
    (let ((dpop-proof
           (issue-dpop-proof
            client-key
            #:alg (case (kty client-key)
                    ((EC) 'ES256)
                    ((RSA) 'RS256)
                    (else
                     (error "Unknown key type of ~S." client-key)))
            #:htm 'POST
            #:htu token-endpoint
            #:iat current-time)))
      (receive (response response-body)
          (http-post token-endpoint
                     #:body
                     (string-join
                      (map
                       (lambda (arg)
                         (string-append (uri-encode (car arg))
                                        "="
                                        (uri-encode (cdr arg))))
                       `(("grant_type" . ,grant-type)
                         ,@(if authorization-code
                               `(("code" . ,authorization-code))
                               '())
                         ,@(if refresh-token
                               `(("refresh_token" . ,refresh-token))
                               '())))
                      "&")
                     #:headers
                     `((content-type application/x-www-form-urlencoded)
                       (dpop . ,dpop-proof)))
        (with-exception-handler
            (lambda (error)
              (raise-token-request-failed error))
          (lambda ()
            (when (bytevector? response-body)
              (set! response-body (utf8->string response-body)))
            (with-exception-handler
                (lambda (error)
                  (raise-unexpected-response response error))
              (lambda ()
                (unless (eqv? (response-code response) 200)
                  (raise-request-failed-unexpectedly
                   (response-code response)
                   (response-reason-phrase response)))
                (unless (and (response-content-type response)
                             (eq? (car (response-content-type response 'application/json))))
                  (raise-unexpected-header-value 'content-type (response-content-type response)))
                (stubs:json-string->scm response-body)))))))))

(define (default-dir)
  (let ((xdg-data-home
         (or
          (getenv "XDG_DATA_HOME")
          (format #f "~a/.local/share"
                  (getenv "HOME")))))
    (format #f "~a/webid-oidc" xdg-data-home)))

(define*-public (list-profiles #:key (dir default-dir))
  (when (thunk? dir)
    (set! dir (dir)))
  (map (lambda (profile)
         (list
          (string->uri (car profile)) ;; webid
          (string->uri (cadr profile)) ;; issuer
          (caddr profile) ;; refresh token
          (cadddr profile))) ;; key
       (catch #t
         (lambda ()
           (call-with-input-file (string-append dir "/profiles")
             read))
         (lambda error
           (format (current-error-port) "Could not read profiles: ~s\n" error)
           '()))))

(define* (add-profile webid issuer refresh-token key
                      #:key (dir default-dir))
  (when (thunk? dir)
    (set! dir (dir)))
  (let ((other-profiles (list-profiles #:dir dir)))
    (stubs:atomically-update-file
     (string-append dir "/profiles")
     (string-append dir "/profiles.lock")
     (lambda (port)
       (write
        (map (lambda (profile)
               (list
                (uri->string (car profile)) ;; webid
                (uri->string (cadr profile)) ;; issuer
                (caddr profile) ;; refresh token
                key)) ;; key
             (cons `(,webid
                     ,issuer
                     ,refresh-token)
                   other-profiles))
        port)))))

(define*-public (setup get-host/webid choose-provider browse-authorization-uri
                       #:key
                       (client-id #f)
                       (redirect-uri #f)
                       (dir default-dir)
                       (http-get http-get)
                       (http-post http-post)
                       (current-time #f))
  (when (thunk? dir)
    (set! dir (dir)))
  (let ((host/webid (get-host/webid)))
    (let ((authorization-uris
           (authorize host/webid
                      #:client-id client-id
                      #:redirect-uri redirect-uri
                      #:http-get http-get))
          (key (generate-key #:n-size 2048)))
      (let ((provider (choose-provider (map car authorization-uris))))
        (let ((authz-uri (assq-ref authorization-uris provider)))
          (let ((authz-code (browse-authorization-uri authz-uri)))
            (let ((params
                   (token host/webid key
                          #:authorization-code authz-code
                          #:http-get http-get
                          #:http-post http-post
                          #:current-time current-time)))
              (let ((id-token (id-token-decode (assq-ref params 'id_token)
                                               #:http-get http-get))
                    (access-token (assq-ref params 'access_token))
                    (refresh-token (assq-ref params 'refresh_token)))
                (when refresh-token
                  ;; Save it to disk
                  (add-profile (id-token-webid id-token)
                               (id-token-iss id-token)
                               refresh-token
                               key
                               #:dir dir))
                (values (cdr id-token) access-token key)))))))))

(define*-public (login webid issuer refresh-token key
                       #:key
                       (dir default-dir)
                       (http-get http-get)
                       (http-post http-post)
                       (current-time #f))
  (when (string? webid)
    (set! webid (string->uri webid)))
  (when (string? issuer)
    (set! issuer (string->uri issuer)))
  (let ((iss-host (uri-host issuer)))
    (let ((params
           (token iss-host key
                  #:refresh-token refresh-token
                  #:http-get http-get
                  #:http-post http-post
                  #:current-time current-time)))
      (let ((id-token (id-token-decode (assq-ref params 'id_token)
                                       #:http-get http-get))
            (access-token (assq-ref params 'access_token))
            (new-refresh-token (assq-ref params 'refresh-token)))
        (when (and new-refresh-token
                   (not (equal? refresh-token new-refresh-token)))
          ;; The refresh token has been updated
          (add-profile (id-token-webid id-token)
                       (id-token-iss id-token)
                       refresh-token
                       key
                       #:dir dir))
        (values (cdr id-token) access-token key)))))

(define*-public (refresh id-token
                         key
                         #:key
                         (dir default-dir)
                         (http-get http-get)
                         (http-post http-post)
                         (current-time #f))
  (when (thunk? dir)
    (set! dir (dir)))
  (when (id-token-payload? id-token)
    ;; For convenience, we’d like a full ID token to use the ID token
    ;; API.
    (set! id-token (cons `((alg . "HS256")) id-token)))
  (let ((profiles (list-profiles #:dir dir)))
    (letrec ((find-refresh-token
              (lambda (profiles)
                (when (null? profiles)
                  (raise-profile-not-found (id-token-webid id-token)
                                           (id-token-iss id-token)
                                           dir))
                (let ((prof (car profiles))
                      (others (cdr profiles)))
                  (let ((webid (car prof))
                        (issuer (cadr prof))
                        (refresh (caddr prof)))
                    (if (and (equal? webid (id-token-webid id-token))
                             (equal? issuer (id-token-iss id-token)))
                        refresh
                        (find-refresh-token others)))))))
      (login (id-token-webid id-token)
             (id-token-iss id-token)
             (find-refresh-token (profiles))
             key
             #:dir dir
             #:http-get http-get
             #:http-post http-post
             #:current-time current-time))))

(define* (renew-if-expired id-token access-token key
                           date
                           #:key
                           (dir default-dir)
                           (http-get http-get)
                           (http-post http-post))
  ;; Since we’re not supposed to decode the access token, we’re
  ;; judging from the ID token to know if it has expired.
  (when (date? date)
    (set! date (date->time-utc date)))
  (when (time? date)
    (set! date (time-second date)))
  (when (id-token-payload? id-token)
    ;; See the refresh function
    (set! id-token (cons `((alg . "HS256")) id-token)))
  (let ((exp (id-token-exp id-token)))
    (set! exp (date->time-utc exp))
    (set! exp (time-second exp))
    (if (>= date exp)
        (refresh id-token key
                 #:dir dir
                 #:http-get http-get
                 #:http-post http-post
                 #:current-time date)
        (values id-token access-token key))))

(define*-public (make-client id-token access-token key
                             #:key
                             (dir default-dir)
                             (http-get http-get)
                             (http-post http-post)
                             (http-request http-request)
                             (current-time the-current-time))
  ;; HACK: guile does not support other authentication schemes in
  ;; WWW-Authenticate than Basic, so it will crash when a response
  ;; containing that header will be issued.
  (declare-header! "WWW-Authenticate" string->symbol symbol? write)
  (define (handler uri method headers other-args current-time retry?)
    (let ((proof (issue-dpop-proof
                  key
                  #:alg (case (kty key)
                          ((EC) 'ES256)
                          ((RSA) 'RS256)
                          (else
                           (error "Unknown key type of ~S." key)))
                  #:htm method
                  #:htu uri
                  #:iat current-time)))
      (receive (response response-body)
          (apply http-request uri
                 #:method method
                 #:headers (append `((dpop . ,proof)
                                     (Authorization . ,(string-append "DPoP " access-token)))
                                   headers)
                 other-args)
        (let ((server-date (response-date response))
              (code (response-code response)))
          (if (and retry? (eqv? code 401))
              ;; Maybe the access token has expired?
              (receive (new-id-token new-access-token new-key)
                  (renew-if-expired id-token access-token key server-date
                                    #:dir dir
                                    #:http-get http-get
                                    #:http-post http-post)
                (if (equal? access-token new-access-token)
                    ;; No, it’s just that way.
                    (values response response-body)
                    ;; Ah, we have a new access token
                    (begin
                      (set! id-token new-id-token)
                      (set! access-token new-access-token)
                      (set! key new-key)
                      (handler uri method headers other-args current-time #f))))
              (values response response-body))))))
  (define (parse-args uri method headers other-args-rev rest)
    (if (null? rest)
        (let ((the-current-time current-time))
          (when (thunk? the-current-time)
            (set! the-current-time (the-current-time)))
          (when (integer? the-current-time)
            (set! the-current-time (make-time time-utc 0 the-current-time)))
          (when (time? the-current-time)
            (set! the-current-time (time-utc->date the-current-time)))
          (handler uri method headers (reverse other-args-rev) the-current-time #t))
        (let ((kw (car rest)))
          (case kw
            ((#:method)
             (if (null? (cdr rest))
                 (parse-args uri method headers (cons kw other-args-rev) '())
                 (parse-args uri (cadr rest) headers other-args-rev (cddr rest))))
            ((#:headers)
             (if (null? (cdr rest))
                 (parse-args uri method headers (cons kw other-args-rev) '())
                 (parse-args uri method (append headers (cadr rest)) other-args-rev (cddr rest))))
            (else
             (parse-args uri method headers (cons kw other-args-rev) '()))))))
  (define (parse-http-request-args uri args)
    (parse-args uri 'GET '() '() args))
  (lambda (uri . args)
    (parse-http-request-args uri args)))

(define*-public (serve-application id redirect-uri
                                   #:key
                                   (client-name "Example application")
                                   (client-uri "https://webid-oidc-demo.planete-kraus.eu"))
  (when (string? id)
    (set! id (string->uri id)))
  (when (string? redirect-uri)
    (set! redirect-uri (string->uri redirect-uri)))
  (when (string? client-uri)
    (set! client-uri (string->uri client-uri)))
  (let* ((manifest
          (format #f
                  "@prefix solid: <http://www.w3.org/ns/solid/terms#> .

<~a> solid:oidcRegistration \"\"\"{
  \"client_id\" : \"~a\",
  \"redirect_uris\" : [\"~a\"],
  \"client_name\" : \"~a\",
  \"client_uri\" : \"~a\",
  \"grant_types\" : [\"refresh_token\", \"authorization_code\"],
  \"response_types\" : [\"code\"]
}\"\"\" .
"
                  (uri->string id)
                  (uri->string id)
                  (uri->string redirect-uri)
                  client-name
                  (uri->string id)))
         (manifest-etag (stubs:hash 'SHA-256 manifest)))
    (lambda (request request-body)
      (let ((uri (request-uri request)))
        (cond
         ((equal? (uri-path uri) (uri-path id))
          (let ((if-none-match (request-if-none-match request)))
            (if (and (list? if-none-match)
                     (member manifest-etag
                             (map car (request-if-none-match request))))
                (values
                 (build-response
                  #:code 304
                  #:reason-phrase "Not Modified"
                  #:headers `((content-type text/turtle)
                              (etag . (,manifest-etag . #t))))
                 #f)
                (values
                 (build-response
                  #:headers `((content-type text/turtle)
                              (etag . (,manifest-etag . #t))
                              (cache-control public must-revalidate)))
                 manifest))))
         ((equal? (uri-path uri) (uri-path redirect-uri))
          (let ((query-args
                 (map
                  (lambda (key=value)
                    (let ((splits
                           (map uri-decode (string-split key=value #\=))))
                      (if (or (null? splits) (null? (cdr splits)))
                          splits
                          (cons (string->symbol (car splits)) (cdr splits)))))
                  (string-split (uri-query uri) #\&))))
            (let ((code (assq-ref query-args 'code)))
              (if code
                  (values
                   (build-response
                    #:headers `((content-type application/xhtml+xml)))
                   (with-output-to-string
                     (lambda ()
                       (sxml->xml
                        `(*TOP*
                          (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                          (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                                   (xml:lang "en"))
                                (head
                                 (title "Authorization"))
                                (body
                                 (p "You have been authorized. Please paste the following code in the application:")
                                 (p (strong ,code)))))))))
                  (values
                   (build-response
                    #:code 400
                    #:reason-phrase "Invalid Request"
                    #:headers `((content-type application/xhtml+xml)))
                   (with-output-to-string
                     (lambda ()
                       (sxml->xml
                        `(*TOP*
                          (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                          (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                                   (xml:lang "en"))
                                (head
                                 (title "Error"))
                                (body
                                 (p "Your identity provider did not authorize you. :("))))))))))))
         (else
          (values
           (build-response
            #:code 404
            #:reason-phrase "Not Found"
            #:headers `((content-type application/xhtml+xml)))
           (with-output-to-string
             (lambda ()
               (sxml->xml
                `(*TOP*
                  (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                  (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                           (xml:lang "en"))
                        (head
                         (title "Not Found"))
                        (body
                         (p "This page does not exist on the server."))))))))))))))

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

(define-public (main-server)
  (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")))
        (client-id-sym
         (string->symbol (G_ "comand-line|client-id")))
        (redirect-uri-sym
         (string->symbol (G_ "comand-line|redirect-uri")))
        (client-name-sym
         (string->symbol (G_ "comand-line|client-name")))
        (client-uri-sym
         (string->symbol (G_ "comand-line|client-uri")))
        (port-sym
         (string->symbol (G_ "comand-line|port")))
        (log-file-sym
         (string->symbol (G_ "comand-line|log-file")))
        (error-file-sym
         (string->symbol (G_ "comand-line|error-file"))))
    (let ((options
           (let ((option-spec
                  `((,version-sym (single-char #\v) (value #f))
                    (,help-sym (single-char #\h) (value #f))
                    (,client-id-sym (single-char #\i) (value #t))
                    (,redirect-uri-sym (single-char #\r) (value #t))
                    (,client-name-sym (single-char #\n) (value #t))
                    (,client-uri-sym (single-char #\u) (value #t))
                    (,port-sym (single-char #\p) (value #t))
                    (,log-file-sym (single-char #\l) (value #t))
                    (,error-file-sym (single-char #\e) (value #t)))))
             (getopt-long (command-line) option-spec))))
      (cond
       ((option-ref options help-sym #f)
        (format #t (G_ "Usage: ~a [OPTIONS]...

Serve public pages for an application.

Options:
  -h, --~a:
      display this help message and exit.
  -v, --~a:
      display the version information (~a) and exit.
  -i URI, --~a=URI:
      set the webid of the client.
  -r FILE, --~a=URI:
      set the redirection URI where to get the authorization code.
  -n NAME, --~a=NAME:
      set the name of the application.
  -u URI, --~a=URI:
      set the address of the application (informative).
  -p PORT, --~a=PORT:
      set the port to bind (instead of 8080).
  -l FILE.log, --~a=FILE.log:
      dump the standard output to that file.
  -e FILE.err, --~a=FILE.err:
      dump the standard error to that file.

Environment variables:

  LANG: set the locale of the sysadmin-facing interface, for log files
and command-line interface. It is currently ~a.

Example used in webid-oidc-demo.planete-kraus.eu (except it’s managed
by shepherd in reality):

    export LANG=C
    webid-oidc-client-service \\
      --client-id 'https://webid-oidc-demo.planete-kraus.eu/example-application#id' \\
      --redirect-uri 'https://webid-oidc-demo.planete-kraus.eu/authorized' \\
      --client-name 'Example Solid Application' \\
      --client-uri 'https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client' \\
      --port $PORT

If you find a bug, send a report to ~a.
")
                (car (command-line))
                help-sym version-sym
                cfg:version
                client-id-sym redirect-uri-sym client-name-sym client-uri-sym port-sym
                log-file-sym error-file-sym
                (or (getenv "LANG") "")
                cfg:package-bugreport))
       ((option-ref options version-sym #f)
        (format #t (G_ "~a version ~a\n")
                cfg:package cfg:version))
       (else
        (let ((client-id (option-ref options client-id-sym #f))
              (redirect-uri (option-ref options redirect-uri-sym #f))
              (client-name (option-ref options client-name-sym "Example Solid App"))
              (client-uri
               (option-ref options client-uri-sym
                           "https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client"))
              (port-string
               (option-ref options port-sym "8080"))
              (log-file-string
               (option-ref options log-file-sym #f))
              (error-file-string
               (option-ref options error-file-sym #f)))
          (when log-file-string
            (set-current-output-port (stubs:open-output-file* log-file-string))
            (setvbuf (current-output-port) 'none))
          (when error-file-string
            (set-current-error-port (stubs:open-output-file* error-file-string))
            (setvbuf (current-error-port) 'none))
          (unless (and client-id (string->uri client-id))
            (format (current-error-port)
                    (G_ "You need to set the client ID as an URI.\n"))
            (exit 1))
          (unless (and redirect-uri (string->uri redirect-uri))
            (format (current-error-port)
                    (G_ "You need to set the redirect URI.\n"))
            (exit 2))
          (unless (string->uri client-uri)
            (format (current-error-port)
                    (G_ "The client URI should be an URI.\n"))
            (exit 3))
          (unless (and (string->number port-string)
                       (integer? (string->number port-string))
                       (>= (string->number port-string) 0)
                       (<= (string->number port-string) 65535))
            (format (current-error-port)
                    (G_ "The port should be a number between 0 and 65535.\n"))
            (exit 1))
          (let ((handler
                 (serve-application client-id redirect-uri
                                    #:client-name client-name
                                    #:client-uri client-uri)))
            (let ((handler-with-log
                   (lambda (request request-body)
                     (with-exception-handler
                         (lambda (error)
                           (format (current-error-port)
                                   (G_ "~a: Internal server error: ~a\n")
                                   (date->string (time-utc->date (current-time)))
                                   (error->str error))
                           (values
                            (build-response #:code 500
                                            #:reason-phrase "Internal Server Error")
                            "Sorry, there was an error."))
                       (lambda ()
                         (handler request request-body))
                       #:unwind? #t))))
              (install-suspendable-ports!)
              (run-server handler 'http
                          (list #:port (string->number port-string)))))))))))