path: root/src/scm/webid-oidc/server/endpoint/identity-provider.scm

;; disfluid, implementation of the Solid specification
;; Copyright (C) 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 server endpoint identity-provider)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc authorization-code)
  #:use-module (webid-oidc oidc-id-token)
  #:use-module (webid-oidc access-token)
  #:use-module (webid-oidc dpop-proof)
  #:use-module (webid-oidc refresh-token)
  #:use-module (webid-oidc oidc-configuration)
  #:use-module (webid-oidc server endpoint)
  #:use-module (webid-oidc provider-confirmation)
  #:use-module (webid-oidc client-manifest)
  #:use-module (webid-oidc jwk)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (web client)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (webid-oidc web-i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (ice-9 control)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (sxml simple)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (oop goops)
  #:use-module (sxml simple)
  #:use-module (rnrs bytevectors)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:export
  (
   <oidc-discovery>
   configuration

   <authorization-endpoint>
   subject
   encrypted-password
   key-file

   <token-endpoint>
   issuer
   ;; key-file

   <jwks-endpoint>
   ;; key-file

   <identity-provider>
   oidc-discovery
   authorization-endpoint
   token-endpoint
   jwks-endpoint
   default
   ))

(define* (read-key-file key-file #:key (create? #f))
  (define returned #f)
  (if create?
      (begin
        (stubs:atomically-update-file
         key-file
         (string-append key-file ".lock")
         (lambda (output-port)
           (catch #t
             (lambda ()
               (call-with-input-file key-file
                 (lambda (port)
                   (set! returned
                         (jwk->key
                          (stubs:json->scm port))))))
             (lambda error
               ;; Generate the key and save it
               (set! returned (generate-key #:n-size 2048))))
           ;; Either the key already existed, so we save the exact same
           ;; key, or it did not, so we save a new one.
           (stubs:scm->json (key->jwk returned) output-port #:pretty #t)
           #t))
        returned)
      ;; Try to read it first:
      (catch #t
        (lambda ()
          (call-with-input-file key-file
            (lambda (port)
              (jwk->key (stubs:json->scm port)))))
        (lambda error
          (format (current-error-port) (G_ "Warning: generating a new key pair.\n"))
          (read-key-file key-file #:create? #t)))))

(define-class <oidc-discovery> (<endpoint>)
  (configuration #:init-keyword #:configuration #:getter configuration))

(define-class <authorization-endpoint> (<endpoint>)
  (subject #:init-keyword #:subject #:getter subject)
  (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password)
  (key-file #:init-keyword #:key-file #:getter key-file))

(define-class <token-endpoint> (<endpoint>)
  (issuer #:init-keyword #:issuer #:getter issuer)
  (key-file #:init-keyword #:key-file #:getter key-file))

(define-class <jwks-endpoint> (<endpoint>)
  (key-file #:init-keyword #:key-file #:getter key-file))

(define-class <identity-provider> (<router>)
  (oidc-discovery #:init-keyword #:oidc-discovery #:getter oidc-discovery)
  (authorization-endpoint #:init-keyword #:authorization-endpoint #:getter authorization-endpoint)
  (token-endpoint #:init-keyword #:token-endpoint #:getter token-endpoint)
  (jwks-endpoint #:init-keyword #:jwks-endpoint #:getter jwks-endpoint))

(define-method (initialize (cfg <oidc-discovery>) initargs)
  (next-method)
  (unless (equal? (path cfg) "/.well-known/openid-configuration")
    (scm-error 'wrong-type-arg "make <oidc-discovery>"
               (G_ "#:path must be exactly \"/.well-known/openid-configuration\"")
               '()
               (list (path cfg))))
  (let-keywords
   initargs #t
   ((configuration #f))
   (unless (is-a? configuration <oidc-configuration>)
     (scm-error 'wrong-type-arg "make <oidc-discovery>"
                (G_ "#:configuration must be an OIDC configuration")
                '()
                (list configuration)))))

(define-method (initialize (a <authorization-endpoint>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((subject #f)
    (encrypted-password #f)
    (key-file #f))
   (match subject
     ((? string? (= string->uri (? uri? subject)))
      (slot-set! a 'subject subject))
     ((? uri?) #t)
     (else
      (scm-error 'wrong-type-arg "make <authorization-endpoint>"
                 (G_ "#:subject should be an URI")
                 '()
                 (list subject))))
   (unless (string? encrypted-password)
     (scm-error 'wrong-type-arg "make <authorization-endpoint>"
                (G_ "#:encrypted-password should be a string")
                '()
                (list encrypted-password)))
   (unless (string? key-file)
     (scm-error 'wrong-type-arg "make <authorization-endpoint>"
                (G_ "#:key-file should be a string")
                '()
                (list key-file)))))

(define-method (initialize (t <token-endpoint>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((issuer #f)
    (key-file #f))
   (match issuer
     ((? string? (= string->uri (? uri? issuer)))
      (slot-set! t 'issuer issuer))
     ((and (? uri?)
           (= uri-path "")
           (= uri-query #f)
           (= uri-fragment #f))
      #t)
     (else
      (scm-error 'wrong-type-arg "make <token-endpoint>"
                 (G_ "#:subject should be an URI without a path, query or fragment")
                 '()
                 (list issuer))))
   (unless (string? key-file)
     (scm-error 'wrong-type-arg "make <token-endpoint>"
                (G_ "#:key-file should be a string")
                '()
                (list key-file)))))

(define-method (initialize (j <jwks-endpoint>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((key-file #f))
   (unless (string? key-file)
     (scm-error 'wrong-type-arg "make <jwks-endpoint>"
                (G_ "#:key-file should be a string")
                '()
                (list key-file)))))

(define-method (initialize (idp <identity-provider>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((oidc-discovery #f)
    (authorization-endpoint #f)
    (token-endpoint #f)
    (jwks-endpoint #f)
    (default #f))
   (match (routed idp)
     (((? (cute eq? <> oidc-discovery))
       (? (cute eq? <> authorization-endpoint))
       (? (cute eq? <> token-endpoint))
       (? (cute eq? <> jwks-endpoint))
       (? (cute eq? <> default)))
      ;; Recursive initialization done
      #t)
     (else
      ;; Re-initialize with the proper endpoints
      (initialize idp
                  `(#:routed (,oidc-discovery
                              ,authorization-endpoint
                              ,token-endpoint
                              ,jwks-endpoint
                              ,default)
                    ,@initargs))))))

(define-method (handle (endpoint <oidc-discovery>) request request-body)
  (let* ((current-sec (time-second (date->time-utc ((p:current-date)))))
         (exp-sec (+ current-sec 3600))
         (exp (time-utc->date
               (make-time time-utc 0 exp-sec))))
    (receive (response response-body)
        (serve (configuration endpoint) exp)
      (values response response-body '()))))

(define (verify-password encrypted-password password)
  (let ((c (crypt password encrypted-password)))
    (format (current-error-port) "Verifying password: given ~s (crypts to ~s) to match ~s\n"
            password c encrypted-password)
    (string=? c encrypted-password)))

(define (split-args str decode-plus-to-space?)
  (format (current-error-port) "Splitting args: ~s, ~s\n" str decode-plus-to-space?)
  (apply append
         (map
          (lambda (k=v)
            (format (current-error-port) "Splitting ~s…\n" k=v)
            (catch #t
              (lambda ()
                (match (string-split k=v #\=)
                  (((= (cute uri-decode <> #:decode-plus-to-space? decode-plus-to-space?)
                       (= string->symbol key))
                    (= uri-decode value))
                   `((,key . ,value)))
                  (else '())))
              (lambda error
                (format (current-error-port) "Can’t split at #\=: ~s\n" error)
                '())))
          (catch #t
            (lambda ()
              (string-split str #\&))
            (lambda error
              (format (current-error-port) "Can’t split at #\&: ~s\n" error)
              '())))))

(define-method (handle (endpoint <authorization-endpoint>) request request-body)
  (format (current-error-port) "Handling in an authorization endpoint: ~s ~s\n" request request-body)
  (let ((query-args
         (split-args
          (uri-query (request-uri request))
          #f))
        (form-args
         (split-args
          (and (match (request-content-type request)
                 ((or 'application/x-www-form-urlencoded
                      ('application/x-www-form-urlencoded _ ...))
                  (format (current-error-port) "The content-type is OK.\n")
                  #t)
                 (else
                  (format (current-error-port) "The content-type is not OK: ~s\n" (request-content-type request))
                  #f))
               (if (bytevector? request-body)
                   (with-exception-handler
                       (lambda (exn)
                         (format (current-error-port) "The request body is not UTF-8: ~s\n" exn)
                         #f)
                     (lambda ()
                       (utf8->string request-body))
                     #:unwind? #t)
                   request-body))
          #t)))
    (format (current-error-port) "Arguments: ~s ~s\n" query-args form-args)
    (let ((client-id
           (match (assq-ref query-args 'client_id)
             ((? string? (= string->uri (? uri? uri)))
              uri)
             (else #f)))
          (redirect-uri
           (match (assq-ref query-args 'redirect_uri)
             ((? string? (= string->uri (? uri? uri)))
              uri)
             (else #f)))
          (password (assq-ref form-args 'password))
          (state (assq-ref query-args 'state)))
      (format (current-error-port) "Arguments: ~s ~s ~s ~s\n" client-id redirect-uri password state)
      (define form
        (if (uri? client-id)
            `(div
              ,(call-with-input-string
                   (format #f (W_ "<h2>Do you wish to authorize <a href=~s>~a</a>?</h2>")
                           (uri->string client-id)
                           (uri->string client-id))
                 xml->sxml)
              (p ,(W_ "If you wish to do so, please type your password:"))
              (form (@ (method "post"))
                    (input (@ (type "password")
                              (name "password")
                              (id "password")))
                    (input (@ (type "submit")
                              (value ,(W_ "Allow"))))))
            '(p)))
      (unless client-id
        (raise-exception
         (make-exception
          (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
          (make-user-message
           `(p ,(W_ "The client_id query argument is not set."))))))
      (unless redirect-uri
        (raise-exception
         (make-exception
          (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
          (make-user-message
           `(p ,(W_ "The redirect_uri query argument is not set."))))))
      (if (eq? (request-method request) 'POST)
          (begin
            (format (current-error-port) "Checking your password…\n")
            (unless (and password (verify-password (encrypted-password endpoint) password))
              (raise-exception
               (make-exception
                (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
                (make-user-message
                 `(p ,(W_ "The password is incorrect.")))
                (make-user-message form))))
            (let ((code (issue <authorization-code>
                               (read-key-file (key-file endpoint))
                               #:webid (subject endpoint)
                               #:client-id client-id))
                  (mf
                   (with-exception-handler
                       (lambda (exn)
                         (raise-exception
                          (make-exception
                           (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
                           (make-user-message
                            (call-with-input-string
                                (format #f (W_ "<p>The client, <a href=~s>~a</a>, cannot be queried.</p>")
                                        (uri->string client-id)
                                        (uri->string client-id))
                              xml->sxml))
                           exn)))
                     (lambda ()
                       (make <client-manifest>
                         #:client-id client-id)))))
              (with-exception-handler
                  (lambda (exn)
                    (raise-exception
                     (make-exception
                      (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
                      (make-user-message
                       (call-with-input-string
                           (format #f (W_ "<p>The real client at <a href=~s>~a</a> does not control the advertised redirection URI.</p>"))
                         xml->sxml))
                      exn)))
                (lambda ()
                  (check-redirect-uri mf redirect-uri)))
              (values
               (build-response
                #:code 302
                #:reason-phrase (W_ "reason-phrase|Found")
                #:headers `((location
                             . ,(build-uri 'https
                                           #:userinfo (uri-userinfo redirect-uri)
                                           #:host (uri-host redirect-uri)
                                           #:port (uri-port redirect-uri)
                                           #:path (uri-path redirect-uri)
                                           #:query
                                           (if state
                                               (format #f "code=~a&state=~a"
                                                       (uri-encode code)
                                                       (uri-encode state))
                                               (string-append "code="
                                                              (uri-encode code)))))
                            (content-type application/xhtml+xml)))
               (call-with-output-string
                 (cute sxml->xml
                       `(*TOP*
                         (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                         (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                                  (xml:lang ,(W_ "xml-lang|en")))
                               (head
                                (title ,(W_ "Redirecting...")))
                               (body
                                (p ,(W_ "You are being redirected.")))))
                       <>))
               '())))
          (values
           (build-response #:headers `((content-type application/xhtml+xml)))
           (call-with-output-string
             (cute sxml->xml
                   `(*TOP*
                     (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
                              (xml:lang ,(W_ "xml-lang|en")))
                           (head
                            (title ,(W_ "Authorization...")))
                           (body ,form)))
                   <>))
           '())))))

(define-method (handle (endpoint <token-endpoint>) request request-body)
  (unless (match (request-content-type request)
            ((or 'application/x-www-form-urlencoded
                 ('application/x-www-form-urlencoded _ ...))
             #t)
            (else #f))
    (raise-exception
     (make-exception
      (make-web-exception 415 (W_ "reason-phrase|Unsupported Media Type"))
      (make-user-message
       (call-with-input-string
           (format #f (W_ "<p>Please use <pre>application/x-www-form-urlencoded</pre>.</p>"))
         xml->sxml)))))
  (when (bytevector? request-body)
    (with-exception-handler
        (lambda (exn)
          (raise-exception
           (make-exception
            (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
            (make-user-message
             (call-with-input-string
                 (format #f (W_ "<p>Expected an UTF-8 request body.</p>"))
               xml->sxml))
            exn)))
      (lambda ()
        (set! request-body (utf8->string request-body)))))
  (unless (eq? (request-method request) 'POST)
    (raise-exception
     (make-exception
      (make-web-exception 405 (W_ "reason-phrase|Method Not Allowed"))
      (make-user-message
       (call-with-input-string
           (format #f (W_ "<p>This is a token endpoint, please use <pre>POST</pre>.</p>"))
         xml->sxml)))))
  (let ((form-args (split-args request-body #t))
        (true-uri
         (let ((server-uri (issuer endpoint)))
           (build-uri (uri-scheme server-uri)
                      #:userinfo (uri-userinfo server-uri)
                      #:host (uri-host server-uri)
                      #:port (uri-port server-uri)
                      #:path (uri-path (request-uri request))
                      #:query (uri-query (request-uri request))))))
    (let ((grant-type (assq-ref form-args 'grant_type))
          (dpop
           (let ((proof (assq-ref (request-headers request) 'dpop)))
             (unless proof
               (raise-exception
                (make-exception
                 (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
                 (make-user-message
                  (call-with-input-string
                      (format #f (W_ "<p>No DPoP proof has been found in your request.</p>"))
                    xml->sxml)))))
             (with-exception-handler
                 (lambda (exn)
                   (raise-exception
                    (make-exception
                     (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
                     (make-user-message
                      (call-with-input-string
                          (format #f (W_ "<p>The DPoP proof is invalid.</p>"))
                        xml->sxml)))))
               (lambda ()
                 (decode <dpop-proof> proof
                         #:method (request-method request)
                         #:uri true-uri
                         #:cnf/check
                         (lambda (jkt) #t)))))))
      (unless grant-type
        (raise-exception
         (make-exception
          (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
          (make-user-message
           (call-with-input-string
               (format #f (W_ "<p>The <pre>grant_type</pre> parameter has not been found.</p>"))
             xml->sxml)))))
      (receive (webid client-id)
          (case (string->symbol grant-type)
            ((authorization_code)
             (let ((code
                    (let ((str (assq-ref form-args 'code)))
                      (unless str
                        (raise-exception
                         (make-exception
                          (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
                          (make-user-message
                           (call-with-input-string
                               (format #f (W_ "<p>Could not find an authorization code.</p>"))
                             xml->sxml)))))
                      (with-exception-handler
                          (lambda (exn)
                            (raise-exception
                             (make-exception
                              (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
                              (make-user-message
                               (call-with-input-string
                                   (format #f (W_ "<p>The authorization code is invalid.</p>"))
                                 xml->sxml))
                              exn)))
                        (lambda ()
                          (decode <authorization-code> str
                                  #:issuer-key (read-key-file (key-file endpoint))))))))
               (values (webid code) (client-id code))))
            ((refresh_token)
             (let ((refresh-token (assq-ref form-args 'refresh_token)))
               (unless refresh-token
                 (raise-exception
                  (make-exception
                   (make-web-exception 400 (W_ "reason-phrase|Bad Requeset"))
                   (make-user-message
                    (call-with-input-string
                        (format #f (W_ "<p>Could not find a refresh token.</p>"))
                      xml->sxml)))))
               (with-exception-handler
                   (lambda (exn)
                     (raise-exception
                      (make-exception
                       (make-web-exception 403 (W_ "reason-phrase|Forbidden"))
                       (make-user-message
                        (call-with-input-string
                            (format #f (W_ "<p>The refresh token is invalid or has been revoked.</p>"))
                          xml->sxml))
                       exn)))
                 (lambda ()
                   (with-refresh-token refresh-token (jwk dpop) values)))))
            (else
             (raise-exception
              (make-exception
               (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
               (make-user-message
                (call-with-input-string
                    (format #f (W_ "<p>Cannot process your grant type, ~a.</p>")
                            (call-with-output-string
                              (cute sxml->xml `(pre ,grant-type) <>)))
                  xml->sxml))))))
        ;; So, either from an authorization code or a refresh token, I
        ;; have a webid and client-id.
        (receive (id-token access-token refresh-token)
            (let ((key-file (read-key-file (key-file endpoint))))
              (let ((id-token
                     (issue <id-token> key-file
                            #:webid webid
                            #:iss (issuer endpoint)
                            #:aud client-id))
                    (access-token
                     (issue <access-token> key-file
                            #:webid webid
                            #:iss (issuer endpoint)
                            #:client-key (jwk dpop)
                            #:client-id client-id))
                    (refresh-token
                     ;; Reuse it if already present
                     (if (equal? grant-type "refresh_token")
                         (assq-ref form-args 'refresh_token)
                         (issue-refresh-token
                          webid client-id (jkt (jwk dpop))))))
                (values id-token access-token refresh-token)))
          (values
           (build-response #:headers '((content-type application/json)
                                       (cache-control (no-cache no-store)))
                           #:port #f)
           (stubs:scm->json-string
            `((id_token . ,id-token)
              (access_token . ,access-token)
              (token_type . "DPoP")
              (expires_in . ,(p:oidc-token-default-validity))
              (refresh_token . ,refresh-token)))
           `((user . ,webid)
             (client-id . ,client-id))))))))

(define-method (handle (endpoint <jwks-endpoint>) request request-body)
  (let ((jwks (make <jwks> #:keys (list (read-key-file (key-file endpoint))))))
    (let* ((current-sec (time-second (date->time-utc ((p:current-date)))))
           (exp-sec (+ current-sec 3600))
           (exp (time-utc->date
                 (make-time time-utc 0 exp-sec))))
      (receive (response response-body)
          (serve jwks exp)
        (values response response-body '())))))