#!/usr/bin/guile18 -s
!#

(use-modules (ice-9 getopt-long)
             (srfi srfi-1)
             (srfi srfi-13)
             (vhttpd)
             (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))

;;; 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 and not daemonize %~%")
  (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-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)))))))))))

(define (uri-handler uri user request)
  (cond
    ((not (acl-check *acl* uri user))
     (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)))))
    (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 (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
		 ((member uri *login-uri-list*)
		    (response-handler uri 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 *server* (make-tls-server (config-ref *config* "server-listen" "*")
				  *server-port*
				  (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)
           (daemonize (config-ref *config* "server-pidfile"))
	   (drop-privs (config-ref *config* "server-user")
		       (config-ref *config* "server-group"))))

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