;; 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 .
(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
(
configuration
subject
encrypted-password
key-file
issuer
;; key-file
;; key-file
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 ()
(configuration #:init-keyword #:configuration #:getter configuration))
(define-class ()
(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 ()
(issuer #:init-keyword #:issuer #:getter issuer)
(key-file #:init-keyword #:key-file #:getter key-file))
(define-class ()
(key-file #:init-keyword #:key-file #:getter key-file))
(define-class ()
(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 ) initargs)
(next-method)
(unless (equal? (path cfg) "/.well-known/openid-configuration")
(scm-error 'wrong-type-arg "make "
(G_ "#:path must be exactly \"/.well-known/openid-configuration\"")
'()
(list (path cfg))))
(let-keywords
initargs #t
((configuration #f))
(unless (is-a? configuration )
(scm-error 'wrong-type-arg "make "
(G_ "#:configuration must be an OIDC configuration")
'()
(list configuration)))))
(define-method (initialize (a ) 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 "
(G_ "#:subject should be an URI")
'()
(list subject))))
(unless (string? encrypted-password)
(scm-error 'wrong-type-arg "make "
(G_ "#:encrypted-password should be a string")
'()
(list encrypted-password)))
(unless (string? key-file)
(scm-error 'wrong-type-arg "make "
(G_ "#:key-file should be a string")
'()
(list key-file)))))
(define-method (initialize (t ) 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 "
(G_ "#:subject should be an URI without a path, query or fragment")
'()
(list issuer))))
(unless (string? key-file)
(scm-error 'wrong-type-arg "make "
(G_ "#:key-file should be a string")
'()
(list key-file)))))
(define-method (initialize (j ) initargs)
(next-method)
(let-keywords
initargs #t
((key-file #f))
(unless (string? key-file)
(scm-error 'wrong-type-arg "make "
(G_ "#:key-file should be a string")
'()
(list key-file)))))
(define-method (initialize (idp ) 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 ) 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)))
(string=? c encrypted-password)))
(define (split-args str decode-plus-to-space?)
(apply append
(map
(lambda (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 '())))
(catch #t
(lambda ()
(string-split str #\&))
(lambda error
'())))))
(define-method (handle (endpoint ) 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 _ ...))
#t)
(else #f))
(if (bytevector? request)
(false-if-exception
(utf8->string request-body))
request-body))
#t)))
(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)))
(define form
(if (uri? client-id)
`(div
,(call-with-input-string
(format #f (W_ "Do you wish to authorize ~a?
")
(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
(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
(read-key-file (key-file endpoint))
#:webid (subject endpoint)
#:client-id client-id))
(mf
(with-exception-handler
(lambda (exn)
(raise-exception
(make-web-exception 400 (W_ "reason-phrase|Bad Request"))
(make-user-message
(call-with-input-string
(format #f (W_ "The client, ~a, cannot be queried.
")
(uri->string client-id)
(uri->string client-id))
xml->sxml))
exn))
(lambda ()
(make
#:client-id client-id)))))
(with-exception-handler
(lambda (exn)
(raise-exception
(make-web-exception 400 (W_ "reason-phrase|Bad Request"))
(make-user-message
(call-with-input-string
(format #f (W_ "The real client at ~a does not control the advertised redirection URI.
"))
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 ) 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_ "Please use
application/x-www-form-urlencoded
.
"))
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_ "Expected an UTF-8 request body.
"))
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_ "This is a token endpoint, please use
POST
."))
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_ "No DPoP proof has been found in your request.
"))
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_ "The DPoP proof is invalid.
"))
xml->sxml)))))
(lambda ()
(decode 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_ "The
grant_type
parameter has not been found."))
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_ "Could not find an authorization code.
"))
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_ "The authorization code is invalid.
"))
xml->sxml))
exn)))
(lambda ()
(decode 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_ "Could not find a refresh token.
"))
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_ "The refresh token is invalid or has been revoked.
"))
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_ "Cannot process your grant type, ~a.
")
(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 key-file
#:webid webid
#:iss (issuer endpoint)
#:aud client-id))
(access-token
(issue 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 ) request request-body)
(let ((jwks (make #: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 '())))))