(define-module (webid-oidc identity-provider)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc authorization-endpoint)
#:use-module (webid-oidc token-endpoint)
#:use-module (webid-oidc oidc-configuration)
#:use-module (webid-oidc jwk)
#:use-module ((webid-oidc config) #:prefix cfg:)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (webid-oidc jti)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web server)
#:use-module (webid-oidc cache)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (ice-9 i18n)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 suspendable-ports)
#:use-module (sxml simple)
#:use-module (srfi srfi-19)
#:use-module (rnrs bytevectors))
(define (G_ text)
(let ((out (gettext text)))
(if (string=? out text)
;; No translation, disambiguate
(car (reverse (string-split text #\|)))
out)))
(define* (same-uri? a b #:key (skip-query #f))
(and (equal? (uri-path a) (uri-path b))
(or skip-query (equal? (uri-query a) (uri-query b)))))
(define*-public (make-identity-provider
issuer
key-file
subject
password
jwks-uri
authorization-endpoint-uri
token-endpoint-uri
jti-list
#:key
(current-time current-time)
(http-get http-get))
(let ((key
(catch #t
(lambda ()
(call-with-input-file key-file stubs:json->scm))
(lambda error
(format (current-error-port)
(G_ "Warning: generating a new key pair."))
(let ((k (generate-key #:n-size 2048)))
(stubs:call-with-output-file*
key-file
(lambda (port)
(stubs:scm->json k port #:pretty #t)))
k)))))
(let ((alg
(if (eq? (kty key) 'RSA)
'RS256
'ES256)))
(let ((authorization-endpoint
(make-authorization-endpoint subject password alg key 120
#:current-time current-time
#:http-get http-get))
(token-endpoint
(make-token-endpoint token-endpoint-uri issuer alg key 3600 jti-list
#:current-time current-time))
(openid-configuration
(make-oidc-configuration jwks-uri
authorization-endpoint-uri
token-endpoint-uri))
(openid-configuration-uri
(build-uri 'https
#:host (uri-host issuer)
#:path "/.well-known/openid-configuration")))
(lambda (request request-body)
(let ((uri (request-uri request))
(current-time (current-time)))
(cond ((same-uri? uri openid-configuration-uri)
(let* ((current-sec (time-second current-time))
(exp-sec (+ current-sec 3600))
(exp (time-utc->date
(make-time time-utc 0 exp-sec))))
(serve-oidc-configuration exp openid-configuration)))
((same-uri? uri jwks-uri)
(let* ((current-sec (time-second current-time))
(exp-sec (+ current-sec 3600))
(exp (time-utc->date
(make-time time-utc 0 exp-sec))))
(serve-jwks exp (make-jwks (list key)))))
((same-uri? uri authorization-endpoint-uri #:skip-query #t)
(authorization-endpoint request request-body))
((same-uri? uri token-endpoint-uri)
(token-endpoint request request-body))
((same-uri? uri subject)
(values
(build-response #:headers '((content-type text/turtle))
#:port #f)
(format #f
"@prefix foaf: .
@prefix rdfs: .
<#~a> a foaf:Person ;
rdfs:comment \"It works. Now you should use another service to serve that resource.\" .
"
(uri-fragment subject))))
(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"))
(body
(h1 "Resource not found")
(p "This OpenID Connect identity provider does not know the resource you are requesting."))))))))))))))))
(define-public (main)
(define* (http-get-with-log uri #:key (headers '()))
(define date (date->string (time-utc->date (current-time))))
(define uri-string (if (uri? uri) (uri->string uri) uri))
(format (current-error-port) "~a: GET ~a ~s...\n"
date uri-string headers)
(receive (response response-body) (http-get uri #:headers headers)
(if response-body
(format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n"
date uri-string headers response
(if (bytevector? response-body)
(bytevector-length response-body)
(string-length response-body)))
(format (current-error-port) "~a: GET ~a ~s: ~s\n"
date uri-string headers response))
(values response response-body)))
(define cache-http-get
(with-cache #:http-get http-get-with-log))
(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")))
(issuer-sym
(string->symbol (G_ "comand-line|issuer")))
(key-file-sym
(string->symbol (G_ "comand-line|key-file")))
(subject-sym
(string->symbol (G_ "comand-line|subject")))
(password-sym
(string->symbol (G_ "comand-line|password")))
(jwks-uri-sym
(string->symbol (G_ "comand-line|jwks-uri")))
(authorization-endpoint-uri-sym
(string->symbol (G_ "comand-line|authorization-endpoint-uri")))
(token-endpoint-uri-sym
(string->symbol (G_ "comand-line|token-endpoint-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))
(,issuer-sym (single-char #\i) (value #t))
(,key-file-sym (single-char #\k) (value #t))
(,subject-sym (single-char #\s) (value #t))
(,password-sym (single-char #\w) (value #t))
(,jwks-uri-sym (single-char #\j) (value #t))
(,authorization-endpoint-uri-sym (single-char #\a) (value #t))
(,token-endpoint-uri-sym (single-char #\t) (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]...
Run the Solid identity provider for a specific user.
Options:
-h, --~a:
display this help message and exit.
-v, --~a:
display the version information (~a) and exit.
-i URI, --~a=URI:
set the public server host name.
-k FILE, --~a=FILE.jwk:
set the file name of the key file. If it does not exist, a new
key is generated.
-s WEBID, --~a=WEBID:
set the identity of the subject.
-w PASSWORD, --~a=PASSWORD:
set the password to recognize the user.
-j URI, --~a=URI:
set the URI to query the key of the server.
-a URI, --~a=URI:
set the authorization endpoint of the issuer.
-t URI, --~a=URI:
set the token endpoint of the issuer.
-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 (the user
pages are translated according to the user agent’s Accept-language
header), for log files and command-line interface. It is currently ~a.
XDG_DATA_HOME: where to store the refresh tokens (under the
webid-oidc directory). For a system service, it is recommended to set
it to /var/lib. Currently set to ~a.
XDG_CACHE_HOME: where to store and update the seed file for the
random number generator. If you remove it, you need to restart the
program to use a different seed. Currently set to ~a.
HOME: if XDG_DATA_HOME or XDG_CACHE_HOME is not set, they are
computed from the value of the HOME environment variable. It is not
used otherwise. Currently set to ~a.
Example used in webid-oidc-demo.planete-kraus.eu (except it’s managed
by shepherd in reality):
export LANG=C
export XDG_DATA_HOME=/var/lib
export XDG_CACHE_HOME=/var/cache
webid-oidc-issuer \\
--issuer https://webid-oidc-demo.planete-kraus.eu \\
--key-file /var/lib/webid-oidc/issuer/key.jwk \\
--subject https://webid-oidc-demo.planete-kraus.eu/profile/card#me \\
--password \"$PASSWORD\" \\
--jwks-uri https://webid-oidc-demo.planete-kraus.eu/keys \\
--authorization-endpoint-uri https://webid-oidc-demo.planete-kraus.eu/authorize \\
--token-endpoint-uri https://webid-oidc-demo.planete-kraus.eu/token \\
--port $PORT
If you find a bug, send a report to ~a.
")
(car (command-line))
help-sym version-sym
cfg:version
issuer-sym key-file-sym subject-sym password-sym
jwks-uri-sym authorization-endpoint-uri-sym
token-endpoint-uri-sym port-sym log-file-sym error-file-sym
(or (getenv "LANG") "")
(or (getenv "XDG_DATA_HOME") "")
(or (getenv "XDG_CACHE_HOME") "")
(or (getenv "HOME") "")
cfg:package-bugreport))
((option-ref options version-sym #f)
(format #t (G_ "~a version ~a\n")
cfg:package cfg:version))
(else
(let ((issuer (option-ref options issuer-sym #f))
(key-file (option-ref options key-file-sym #f))
(subject (option-ref options subject-sym #f))
(password (option-ref options password-sym #f))
(jwks-uri (option-ref options jwks-uri-sym #f))
(authorization-endpoint-uri
(option-ref options authorization-endpoint-uri-sym #f))
(token-endpoint-uri
(option-ref options token-endpoint-uri-sym #f))
(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))
(jti-list (make-jti-list)))
(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 issuer (string->uri issuer))
(format (current-error-port)
(G_ "You need to set the issuer.\n"))
(exit 1))
(unless key-file
(format (current-error-port)
(G_ "You need to set the file name of the key file.\n"))
(exit 1))
(unless (and subject (string->uri subject))
(format (current-error-port)
(G_ "You need to set the identity of the subject.\n"))
(exit 1))
(unless password
(format (current-error-port)
(G_ "You need to set the password to verify the identity of the subject.\n"))
(exit 1))
(unless (and jwks-uri (string->uri jwks-uri))
(format (current-error-port)
(G_ "You need to set the JWKS URI.\n"))
(exit 1))
(unless (and authorization-endpoint-uri
(string->uri authorization-endpoint-uri))
(format (current-error-port)
(G_ "You need to set the authorization endpoint URI.\n"))
(exit 1))
(unless (and token-endpoint-uri
(string->uri token-endpoint-uri))
(format (current-error-port)
(G_ "You need to set the token endpoint URI.\n"))
(exit 1))
(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
(make-identity-provider
(string->uri issuer)
key-file
(string->uri subject)
password
(string->uri jwks-uri)
(string->uri authorization-endpoint-uri)
(string->uri token-endpoint-uri)
jti-list
#:current-time current-time
#:http-get cache-http-get)))
(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 ()
(with-exception-handler
(lambda (error)
(format (current-error-port)
(G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n")
((record-accessor &unknown-client-locale 'web-locale) error)
((record-accessor &unknown-client-locale 'c-locale) error)
(error->str error)))
(lambda ()
(handler request request-body))
#:unwind? #t
#:unwind-for-type &unknown-client-locale))
#:unwind? #t))))
(install-suspendable-ports!)
(run-server handler-with-log 'http (list #:port (string->number port-string)))))))))))