path: root/src/scm/webid-oidc/access-token.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 access-token)
  #:use-module (webid-oidc jws)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc jwk)
  #:use-module (webid-oidc oidc-configuration)
  #:use-module (webid-oidc web-i18n)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 exceptions)
  #:declarative? #t
  #:export
  (

   &invalid-access-token
   make-invalid-access-token
   invalid-access-token?

   the-access-token
   access-token?

   access-token-alg

   access-token-webid
   access-token-iss
   access-token-aud
   access-token-iat
   access-token-exp
   access-token-client-id
   access-token-cnf/jkt

   access-token-decode
   issue-access-token
   ))

(define-exception-type
  &invalid-access-token
  &external-error
  make-invalid-access-token
  invalid-access-token?)

;; The order is meaningful in this module, the-access-token reorders
;; them.
(define (the-access-token x)
  (with-exception-handler
      (lambda (error)
        (let ((final-message
               (cond
                ((invalid-jws? error)
                 (if (exception-with-message? error)
                     (format #f (G_ "this is not an access token, because it is not even a JWS: ~a")
                             (exception-message error))
                     (format #f (G_ "this is not an access token, because it is not even a JWS"))))
                (else
                 (if (exception-with-message? error)
                     (format #f (G_ "this is not an access token: ~a")
                             (exception-message error))
                     (format #f (G_ "this is not an access token")))))))
          (raise-exception
           (make-exception
            (make-invalid-access-token)
            (make-exception-with-message final-message)
            error))))
    (lambda ()
      (match (the-jws x)
        ((header . payload)
         (let examine-payload ((payload payload)
                               (webid #f)
                               (iss #f)
                               (aud #f)
                               (iat #f)
                               (exp #f)
                               (cnf #f)
                               (client-id #f)
                               (other-fields '()))
           (match payload
             (()
              (unless (and webid iss aud iat exp cnf client-id)
                ;; Missing some things
                (fail (format #f (G_ "the payload is missing ~s")
                              `(,@(if webid '() '("webid"))
                                ,@(if iss '() '("iss"))
                                ,@(if aud '() '("aud"))
                                ,@(if iat '() '("iat"))
                                ,@(if exp '() '("exp"))
                                ,@(if cnf '() '("cnf"))
                                ,@(if client-id '() '("client_id"))))))
              `(,header
                . ((webid . ,(uri->string webid))
                   (iss . ,(uri->string iss))
                   (aud . "solid")
                   (iat . ,(time-second (date->time-utc iat)))
                   (exp . ,(time-second (date->time-utc exp)))
                   (client_id . ,(uri->string client-id))
                   (cnf . ,cnf)
                   ,@(reverse other-fields))))
             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
              (examine-payload payload
                               (or webid webid-given)
                               iss aud iat exp cnf client-id other-fields))
             ((('webid . infringing) payload ...)
              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
                            infringing)))
             ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...)
              (examine-payload payload webid
                               (or iss iss-given)
                               aud iat exp cnf client-id other-fields))
             ((('iss . infringing) payload ...)
              (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given")
                            infringing)))
             ((('aud . "solid") payload ...)
              (examine-payload payload webid iss #t iat exp cnf client-id other-fields))
             ((('aud . infringing) payload ...)
              (fail (format #f (G_ "the \"aud\" field should be set to \"solid\", ~s is given")
                            infringing)))
             ((('iat . (? (cute >= <> 0) (? integer? iat-given))) payload ...)
              (examine-payload payload webid iss aud
                               (or iat (time-utc->date (make-time time-utc 0 iat-given)))
                               exp cnf client-id other-fields))
             ((('iat . infringing) payload ...)
              (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given")
                            infringing)))
             ((('exp . (? (cute >= <> 0) (? integer? exp-given))) payload ...)
              (examine-payload payload webid iss aud iat
                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
                               cnf client-id other-fields))
             ((('exp . infringing) payload ...)
              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
                            infringing)))
             ((('cnf . cnf) payload ...)
              (let examine-cnf ((data cnf)
                                (jkt #f)
                                (other-cnf-fields '()))
                (match data
                  (()
                   (unless jkt
                     (fail (format #f (G_ "the \"cnf\" / \"jkt\" field is missing"))))
                   (examine-payload payload webid iss aud iat exp
                                    `((jkt . ,jkt)
                                      ,@(reverse other-cnf-fields))
                                    client-id other-fields))
                  ((('jkt . (? string? jkt-given)) data ...)
                   (examine-cnf data (or jkt jkt-given other-cnf-fields) other-cnf-fields))
                  ((('jkt . infringing) _ ...)
                   (fail (format #f (G_ "the \"cnf\" / \"jkt\" field should be a string, ~s is given")
                                 infringing)))
                  ((field data ...)
                   (examine-cnf data jkt `(,field ,@other-cnf-fields)))
                  (data
                   (fail (format #f (G_ "the \"cnf\" field should be an object, ~s is given")
                                 data))))))
             ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...)
              (examine-payload payload webid iss aud iat exp cnf
                               (or client-id client-id-given)
                               other-fields))
             ((('client_id . infringing) payload ...)
              (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given")
                            infringing)))
             ((field payload ...)
              (examine-payload payload webid iss aud iat exp cnf client-id
                               `(,field ,@other-fields))))))
        (else
         (scm-error 'wrong-type-arg "the-access-token"
                    "expected a pair of lists"
                    (list x)))))))

(define (access-token? x)
  (false-if-exception (the-access-token x)))

(define (access-token-alg code)
  (match (the-access-token code)
    ((header . _)
     (string->symbol (assq-ref header 'alg)))))

(define (access-token-webid code)
  (match (the-access-token code)
    ((_ . payload)
     (string->uri (assq-ref payload 'webid)))))

(define (access-token-iss code)
  (match (the-access-token code)
    ((_ . payload)
     (string->uri (assq-ref payload 'iss)))))

(define (access-token-aud code)
  (match (the-access-token code)
    ((_ . payload)
     (assq-ref payload 'aud))))

(define (access-token-iat code)
  (match (the-access-token code)
    ((_ . payload)
     (time-utc->date
      (make-time time-utc 0 (assq-ref payload 'iat))))))

(define (access-token-exp code)
  (match (the-access-token code)
    ((_ . payload)
     (time-utc->date
      (make-time time-utc 0 (assq-ref payload 'exp))))))

(define (access-token-client-id code)
  (match (the-access-token code)
    ((_ . payload)
     (string->uri (assq-ref payload 'client-id)))))

(define (access-token-cnf/jkt code)
  (match (the-access-token code)
    ((_ . payload)
     (assq-ref (assq-ref payload 'cnf) 'jkt))))

(define* (access-token-decode str #:key (http-get http-get))
  (with-exception-handler
      (lambda (error)
        (let ((final-message
               (if (exception-with-message? error)
                   (format #f (G_ "the access token is invalid: ~a")
                           (exception-message error))
                   (format #f (G_ "the access token is invalid")))))
          (raise-exception
           (make-exception
            (make-invalid-access-token)
            (make-exception-with-message final-message)
            error))))
    (lambda ()
      (jws-decode
       str
       (lambda (token)
         (let* ((iss (access-token-iss token))
                (cfg
                 (with-exception-handler
                     (lambda (error)
                       (let ((final-message
                              (if (exception-with-message? error)
                                  (format #f (G_ "I cannot query the identity provider configuration: ~a")
                                          (exception-message error))
                                  (format #f (G_ "I cannot query the identity provider configuratioon")))))
                         (raise-exception
                          (make-exception
                           (make-cannot-query-identity-provider iss)
                           (make-exception-with-message final-message)
                           error))))
                   (lambda ()
                     (get-oidc-configuration
                      (uri-host iss)
                      #:userinfo (uri-userinfo iss)
                      #:port (uri-port iss)
                      #:http-get http-get))))
                (jwks
                 (with-exception-handler
                     (lambda (error)
                       (let ((final-message
                              (if (exception-with-message? error)
                                  (format #f (G_ "I cannot query the identity provider public keys: ~a")
                                          (exception-message error))
                                  (format #f (G_ "I cannot query the identity provider public keys")))))
                         (raise-exception
                          (make-exception
                           (make-cannot-query-identity-provider iss)
                           (make-exception-with-message final-message)
                           error))))
                   (lambda ()
                     (oidc-configuration-jwks cfg #:http-get http-get)))))
           (let ((iat (access-token-iat token))
                 (exp (access-token-exp token))
                 (current-date ((p:current-date))))
             (let ((iat-s (time-second (date->time-utc iat)))
                   (exp-s (time-second (date->time-utc exp)))
                   (current-s (time-second (date->time-utc current-date))))
               (when (>= iat-s (+ current-s 5))
                 (let ((final-message
                        (format #f (G_ "the access token is signed in the future, ~a, relative to current ~a")
                                (date->string iat)
                                (date->string current-date))))
                   (raise-exception
                    (make-exception
                     (make-signed-in-future iat current-date)
                     (make-exception-with-message final-message)))))
               (when (>= current-s exp-s)
                 (let ((final-message
                        (format #f (G_ "the access token expired ~a, which is in the past (from ~a)")
                                (date->string exp)
                                (date->string current-date))))
                   (raise-exception
                    (make-exception
                     (make-expired exp current-date)
                     (make-exception-with-message final-message)))))))
           jwks))))))

(define (access-token-encode access-token key)
  (with-exception-handler
      (lambda (error)
        (let ((final-message
               (if (exception-with-message? error)
                   (format #f (G_ "cannot encode the access token: ~a")
                           (exception-message error))
                   (format #f (G_ "cannot encode the access token")))))
          (raise-exception
           (make-exception-with-message final-message))))
    (lambda ()
      (jws-encode access-token key))))

(define* (issue-access-token
          issuer-key
          #:key
          (alg #f)
          (webid #f)
          (iss #f)
          (validity 3600)
          (client-key #f)
          (cnf/jkt #f)
          (client-id #f))
  (when client-key
    (set! cnf/jkt (jkt client-key)))
  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
         (exp (+ iat validity)))
    (jws-encode
     (the-access-token
      `(((alg . ,(symbol->string alg)))
        . ((webid . ,(uri->string webid))
           (iss . ,(uri->string iss))
           (aud . "solid")
           (iat . ,iat)
           (exp . ,exp)
           (cnf . ((jkt . ,cnf/jkt)))
           (client_id . ,(uri->string client-id)))))
     issuer-key)))