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

(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: <http://xmlns.com/foaf/0.1/> .
@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .

<#~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 https://webid-oidc-demo.planete-kraus.eu/authorize \\
      --token-endpoint 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 (open-output-file* log-file-string))
            (setvbuf (current-output-port) 'none))
          (when error-file-string
            (set-current-error-port (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_ "Internal server error: ~a\n")
                                   (error->str error))
                           (values
                            (build-response #:code 500
                                            #:reason-phrase "Internal Server Error")
                            "Sorry, there was an error."))
                       (lambda ()
                         (handler request request-body))))))
              (install-suspendable-ports!)
              (run-server handler 'http (list #:port (string->number port-string)))))))))))