#!/usr/bin/guile --no-auto-compile
!#

(use-modules (ice-9 getopt-long)
             (srfi srfi-1)
             (srfi srfi-13)
             (vhttpd)
             (alterator systemd)
             (alterator d)
             (alterator woo)
             (alterator str)
             (alterator algo)
             (alterator config)
             (alterator common)
             (alterator exit-handler)
             (alterator ahttpd)
             (alterator ajax)
             (alterator ahttpd acl)
             (alterator ahttpd response)
             (alterator session)
             (alterator plist))

;;; options processing
(define (usage)
  (format #t "Usage:  ~A [-ld] [-c config]~%" program-name)
  (format #t "  -c,--config  [config file] use specified config file instead of default~%")
  (format #t "  -l,--local   try to use local files (backends,design,templates,etc.) if available %~%")
  (format #t "  -d,--debug   turn on debugging %~%")
  (format #t "  Report bugs to <inger@altlinux.ru>~%")
  (quit))

(define *option-spec*
  '((help  (single-char #\h) (value #f))
    (config (single-char #\c) (value #t))
    (local (single-char #\l) (value #f))
    (debug (single-char #\d) (value #f))))

(define *options* (getopt-long (command-line) *option-spec*))

(and (option-ref *options* 'help #f) (usage))
(and (option-ref *options* 'debug #f) (turn-on-debugging))

;;; configuration

(define *config-name* (option-ref *options* 'config "/etc/ahttpd/ahttpd.conf"))
(define *config* (open-file-config *config-name*))
(define *server-port* (config-ref *config* "server-port" "8080"))
(define *server-host* (config-ref *config* "server-host" "localhost"))
(define *server-acl* (config-ref *config* "server-acl" "/etc/ahttpd/acl.conf"))
(define *server-auth* (if (option-ref *options* 'local #f)
                          "none"
                          (string->symbol (config-ref *config* "server-auth" "session"))))
(define *server-root* (delay (string-cut (or (getenv "ALTERATOR_DATADIR") "") #\:)))

;;; auth selection
(define (none-auth-check request)
  "root")

(define (none-auth-challenge uri request)
  'ignore)

(define (session-auth-check request)
  (session-user (message-cookie request "session")))

(define (session-auth-challenge uri request)
  (let ((query (message-query request)))
    (make-redirect-response
     (format #f "~A?continue=~A"
             *login-uri*
             (encode-url-component (string-append uri
                                                  (if (string-null? query) "" "?")
                                                  query))))))

(define *server-auth-check* (case *server-auth*
                              ((session) session-auth-check)
                              (else none-auth-check)))

(define *server-auth-challenge* (case *server-auth*
                                  ((session) session-auth-challenge)
                                  (else none-auth-challenge)))

;;; tune behaviour
(define *framework-uri* (config-ref *config* "framework-uri" "/acc"))
(define *login-uri* (config-ref *config* "login-uri" "/login"))
(define *logout-uri* (config-ref *config* "logout-uri" "/logout"))
(define *login-uri-list* (list *login-uri* *logout-uri*))

(define (server-host request)
  (or (message-header request "host")
      *server-host*))

;;; acl
(define *acl* (make-acl (open-file-config *server-acl*)))

;;; logging
(define *log-file* (config-ref *config* "log-file"))
(define *log-mode* (string->symbol (config-ref *config* "log-mode" "none")))
(define *log* (open-file *log-file* "a"))

(define (current-gmt-time)
  (strftime "%a, %d %b %Y %T GMT"
            (gmtime (current-time))))

(define (error-code? code)
  (< 399 code 600))

(define (log-message request response)
  (let ((retcode (message-code response)))
    (if (or (eq? *log-mode* 'all)
            (and (eq? *log-mode* 'errors)
                 (error-code? retcode)))
        (begin
          (format *log*
                  "~A\t~S\t~S\t~S~%"
                  (message-header request "remote-addr")
                  (current-gmt-time)
                  (message-startline request)
                  (format #f "~A - ~A" retcode (message-code-string retcode)))
          (force-output *log*))))
  response)

;;; handlers
(define (response-handler uri request)
  (let ((framework-uri (if (member uri *login-uri-list*) uri *framework-uri*)))
    (with-fluids ((woo-gate d-query)) ;;global woo gate
                 (with-ahttpd-session ;;global data
                  request
                  uri
                  (lambda()
                    (ahttpd-session-set! 'ahttpd-config *config*)
                    (ahttpd-pause/resume ;;continuation break point
                     (lambda()
                       (cond
                        ((cond-assoc "ajax" (message-url-args request))
                         =>
                         (lambda(callbackname)
                           (make-ajax-response uri callbackname)))
                        (else
                         (or (make-ui-response uri)
                             (make-alterator-response framework-uri uri request)))))))))))

;;
;;--------- CSRF token insert-remove
;; insert on response
;; remove on incoming call
;;


(define (get-csrf-token-for-request request)
  (woo-get-option (woo-read-first '/csrf-token/get 'session_id (message-cookie request "session")) 'token))

(define (request-is-safe request)
  (and (equal? (message-url-args request) '())
       (equal? (message-request-args request) '())))



(define (csrf-strip-token uri request)
  (with-fluids ((woo-gate d-query))
               (let ((tested-token (car (cdr (string-split uri #\/))))
                     (stored-token (get-csrf-token-for-request request)))
                 (if (equal? tested-token stored-token)
                     (unsafe-strip-token uri)
                     (if (option-ref *options* 'local #f) #f "/")))))


(define (uri-handler uri user request)
  (uri-handler-next
   (or (csrf-strip-token uri request)
       (if (request-is-safe request)
           uri
           "/"))
   user
   request))

;; we check presence of token in url validity of it
;; and if it fails we redirect to /

(define (uri-handler-next uri user request)
  (cond
   ((and (not (acl-check *acl* uri user)) (not (uri-prefix?  "/ahttpd/help" uri)))
    (make-error-response 403 "access denied"))
   (else (response-handler uri request))))

(define (catch-strerror key args)
  (case key
    ((woo-error)
     (format #f "Backend: ~A" (car args)))
    ((xml-error)
     (format #f "XML Parser: ~A"  (car args)))
    ((system-error)
     (format #f "System error: ~A" (strerror (system-error-errno (cons key args)))))
    ((wrong-type-arg wrong-number-of-args misc-error)
        (if (car args)
          (format #f "Error evaluating ~A:~%~A"
                     (append (list (car args)) (or (cadddr args) '()))
                     (apply format #f (cadr args) (caddr args)))
          (apply format #f (cadr args) (caddr args))))
    (else (format #f "~S" (cons key args)))))

(define (static-handler uri request)
  (let ((mtime (or (message-header request "if-modified-since") "")))
    (or (any (lambda(prefix)
               (make-file-response (string-append prefix uri) mtime))
             (force *server-root*))
        (make-error-response 404 "not found"))))

(define (dump-session session)
  (display (->json
            (if (and session
                     (not (null? session)))
                (list 'user (session-obj-ref session 'user)
                      'timestamp (session-obj-ref session 'timestamp))
                '()))))

(define (cache-request-handler uri request)
  (let ((uri-parts (string-split uri #\/)))
    (case (string->symbol (car uri-parts))
      ((sessions)
       (let ((session (and (> (length uri-parts) 1)
                           (session-obj (cadr uri-parts)))))
         (if session
             (make-string-response 200 "text/plain"
                                   (with-output-to-string
                                     (lambda ()
                                       (dump-session session))))
             (make-error-response 404 "session not found"))))
      (else
       (make-error-response 404 "object not found")))))

(define (message-handler code request)
  (log-message
   request
   (catch #t
          (lambda()
            (let* ((uri (or (message-uri request) "/"))
                   (uri (string-append "/" (string-trim-both uri #\/)))
                   (user (*server-auth-check* request)))
              (cond
               ;;common problems
               ((not (= code 200))
                (make-error-response code ""))
               ((message-plain? request)
                (make-redirect-response (format #f "https://~A:~A" (server-host request) *server-port*)))
               ((or (not (string? uri)) (string-contains uri "..") (string-contains uri "//"))
                (make-error-response 400 "malformed uri"))
               ;;static handler
               ((string=? "/favicon.ico" uri)
                (make-error-response 404 "not supported"))
               ((uri-prefix? "/design" uri)
                (static-handler uri request))
               ;;login and logout gates
               ((string=? *login-uri* uri)
                (response-handler uri request))
               ((string=? *logout-uri* (unsafe-strip-token uri))
                (response-handler (or (csrf-strip-token uri request) "/") request))
               ((equal? "/ahttpd-cache" (string-join (list-head (string-split uri #\/) 2) "/"))
                (cache-request-handler (string-join (list-tail (string-split uri #\/) 2) "/") request))
               ((string? user)
                (uri-handler uri user request))
               (else
                (*server-auth-challenge* uri request)))))
          (lambda (key . args)
            (make-error-response 500
                                 (catch-strerror key args))))))

;;; main

(sigaction SIGHUP SIG_IGN)
(sigaction SIGPIPE SIG_IGN)

(define *fds* (sd-listen-fds))

(define (make-ahttpd-server key-file cert-file)
  (if (and *fds* (not (null? *fds*)))
      (begin
        (format *log* "*** Make server from the given socket ***~%")
        (force-output *log*)
        (make-tls-server-from-socket (car *fds*) key-file cert-file))
      (begin
        (format *log* "*** Make a new server socket ***~%")
        (force-output *log*)
        (make-tls-server (config-ref *config* "server-listen" "*")
                         *server-port*
                         key-file
                         cert-file))))

(define *server* (make-ahttpd-server (config-ref *config* "tls-key-file")
                                     (config-ref *config* "tls-cert-file")))

(if (option-ref *options* 'local #f)
    (begin (alterator-init-local)
           (d-init-local))
    (begin (alterator-init-global)
           (drop-privs (config-ref *config* "server-user")
                       (config-ref *config* "server-group"))))

(with-exit-handler
 (lambda()
   (server-loop *server* message-handler)))
