#!/usr/bin/guile16 -s
!#

(use-modules (ice-9 getopt-long)
             (srfi srfi-13)
             (vhttpd)
             (ahttpd config)
	     (ahttpd acl)
             (ahttpd response)
             (ahttpd alterator)
             (ahttpd auth basic)

             (alterator http utils));;for uri-prefix?

;;; configuration

(define *config-name* "/etc/ahttpd/ahttpd.conf")
(define *config* (open-file-config *config-name*))
(define *server-port* (config-ref *config* "server-port"))
(define *server-host* (config-ref *config* "server-host" "localhost"))
(define *server-root1* "/var/www/html/")
(define *server-root2* "/usr/share/alterator/")

(define *alterator-socket* (config-ref *config* "alterator-socket"))

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

(define (reload-config)
 (set! *config* (open-file-config *config-name*)))

;;; acl
(define *acl* (make-acl (open-file-config "/etc/ahttpd/acl.conf")))

;;; 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 (uri-handler uri user request)
  (cond
    ;;static handler
    ((uri-prefix? "/fbi" uri)
     (or (make-file-response (string-append *server-root1* uri)
			     (or (message-header request "if-modified-since") ""))
	 (make-error-response 404 "not found")))
    ((uri-prefix? "/design" uri)
     (or (make-file-response (string-append *server-root2* uri)
			     (or (message-header request "if-modified-since") ""))
	 (make-error-response 404 "not found")))
    ;;language cgi emulation
    ((uri-prefix? "/language" uri)
     (make-redirect-response (or (message-header request "referer") "/")
			     (cons "language"
				   (string-append
				     (basename uri) ";expires=Mon 18-01-2038 01:00:00 GMT;path=/;secure"))))
    ((uri-prefix? "/reload" uri)
     (reload-config)
     (let* ((idx (string-index uri #\/ 1))
            (path (if idx (substring uri idx) "/"))
	    (host (server-host request))
	    (port (config-ref *config* "server-port"))
	    (answer (make-reload-response host port path)))
         (system "/usr/sbin/configd-cmdline /ahttpd-server reload >&2");;TODO: reload itself
	 answer))
    (else
      (if (acl-check *acl* uri user)
	(make-alterator-response *alterator-socket*
				 uri
				 request)
	(make-error-response 403 "access denied")))))

(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 (basic-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 ".."))
		  (make-error 400 "malformed uri"))
		 ((string? user)
		    (uri-handler uri user request))
		 (else
		   (basic-auth-challenge "System Administrator")))))
	   (lambda (key . args)
	     (case key
	       ((system-error)
		(make-error-response 500 (format #f "system-error=~S"
					(strerror (system-error-errno (cons key args))))))
	       (else
		 (make-error-response 500 (format #f "key=~S,args=~S~%"
					 key args))))))))

;;; main
(define (usage progname)
  (format #t "Usage:  ~A [-l]~%" progname)
  (format #t "  -l,--local   try to use local files (maps,po,layout,etc.) if available and not daemonize %~%")
  (format #t "  Report bugs to <inger@altlinux.ru>~%")
  (quit))

(define option-spec
  '((help  (single-char #\h) (value #f))
    (local (single-char #\l) (value #f))))

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

(and (option-ref options 'help #f) (usage progname))

(sigaction SIGHUP SIG_IGN)
(sigaction SIGPIPE SIG_IGN)

(define *channel* (make-tls-channel (config-ref *config* "server-listen")
				    (config-ref *config* "server-port")
				    (config-ref *config* "tls-key-file")
				    (config-ref *config* "tls-cert-file")))

(or (option-ref options 'local #f)
    (begin (daemonize (config-ref *config* "server-pidfile"))
	   (drop-privs (config-ref *config* "server-user")
		       (config-ref *config* "server-group"))))

(message-loop *channel* message-handler)
