;; webid-oidc, implementation of the Solid specification
;; Copyright (C) 2020, 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 hello-world)
  #:use-module (webid-oidc resource-server)
  #:use-module (webid-oidc jti)
  #:use-module ((webid-oidc config) #:prefix cfg:)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web server)
  #: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))

(define (G_ text)
  (let ((out (gettext text)))
    (if (string=? out text)
        ;; No translation, disambiguate
        (car (reverse (string-split text #\|)))
        out)))

(define-public (main)
  (setvbuf (current-output-port) 'none)
  (setvbuf (current-error-port) 'none)
  (setlocale LC_ALL "")
  (bindtextdomain cfg:package cfg:localedir)
  (textdomain cfg:package)
  (let ((version-sym
         (string->symbol (G_ "command-line|version")))
        (complete-corresponding-source-sym
         (string->symbol (G_ "command-line|complete-corresponding-source")))
        (help-sym
         (string->symbol (G_ "comand-line|help")))
        (port-sym
         (string->symbol (G_ "comand-line|port"))))
    (let ((options
           (let ((option-spec
                  `((,complete-corresponding-source-sym (single-char #\S) (value #t))
                    (,version-sym (single-char #\v) (value #f))
                    (,help-sym (single-char #\h) (value #f))
                    (,port-sym (single-char #\p) (value #t)))))
             (getopt-long (command-line) option-spec))))
      (cond
       ((option-ref options help-sym #f)
        (format #t (G_ "~a [OPTIONS]...

Display your identity contained in the XXX-Agent header.

This program is covered by the GNU Affero GPL, version 3 or
later. This license requires you to provide a way for any user over
the network to download the complete corresponding source code (with
your modifications) at no cost. The server adds a \"Source:\" header
to all responses.

Options:
  -S MEANS, --~a=MEANS:
      specify a way to download the complete corresponding source
      code. For instance, this would be an URI pointing to a tarball.
  -h, --~a:
      display this help message and exit.
  -v, --~a:
      display the version information (~a) and exit.
  -p PORT, --~a=PORT:
      set the port to bind.
")
                (car (command-line))
                complete-corresponding-source-sym
                help-sym version-sym
                cfg:version
                port-sym))
       ((option-ref options version-sym #f)
        (format #t (G_ "~a version ~a\n")
                cfg:package cfg:version))
       (else
        (let ((port-string
               (option-ref options port-sym "8080"))
              (means-string
               (let ((str (option-ref options complete-corresponding-source-sym #f)))
                 (unless str
                   (format (current-error-port)
                           (G_ "You are legally required to link to the complete corresponding source code.\n"))
                   (exit 1))
                 str))
              (jti-list (make-jti-list)))
          (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
                 (lambda (request request-body)
                   (if (eq? (request-method request) 'GET)
                       (let ((agent (assoc-ref (request-headers request) 'xxx-agent)))
                         (if (and agent (string->uri agent))
                             (values
                              (build-response
                               #:headers `((content-type application/xhtml+xml)
                                           (source . ,means-string)))
                              (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 "Hello, "
                                                      (a (@ (href ,(uri->string (string->uri agent))))
                                                         ,(uri->string (string->uri agent))) "!"))))))))
                             (values
                              (build-response #:code 401
                                              #:reason-phrase "Unauthorized"
                                              #:headers `((content-type application/xhtml+xml)
                                                          (source . ,means-string)))
                              (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 "Please authenticate!"))))))))))
                       (values
                        (build-response #:code 405
                                        #:reason-phrase "Method Not Allowed"
                                        #:headers `((content-type application/xhtml+xml)
                                                    (source . ,means-string)))
                        (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 "Please issue a GET request."))))))))))))
            (install-suspendable-ports!)
            (run-server handler 'http (list #:port (string->number port-string))))))))))