;;;===========================================================================
;;;
;;; weblisp.lisp
;;;
;;; Eduardo Muņoz
;;; Time-stamp: "Monday, 13 June 2005 - 01:24:12"
;;;
;;;===========================================================================

(in-package :cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:operate 'asdf:load-op :clsql)
  ;; (asdf:operate 'asdf:load-op :clsql-postgresql)
  (asdf:operate 'asdf:load-op :clsql-postgresql-socket)
  (asdf:operate 'asdf:load-op :cl-ppcre))

(setq clsql:*default-caching* nil)

(defpackage #:weblisp
  (:nicknames #:wl)
  (:use #:cl)
  (:export #:list-apache-addresses
           #:delete-apache-address
           #:test-apache-address
           #:compile-weblisp-file
           #:build-web #:start-web #:restart-web
           #:show-compiled-pages))

(in-package :weblisp)


(defvar *apache-address-table* (make-hash-table :test #'equalp :size 50))

(defparameter *apache-document-root* "/home/emf/www")

(defparameter *weblisp-files* '("lib/htout" "macros" "pages" "utils" "hack"
                                "log" "errors" "lib/mod-lisp" "autocad"
                                "bookmarks" "emacs"  "lisp" "misc" "news" "play"
                                "test" "weblog" "weblog-master" "whois"))

(defparameter *source-path* "/home/emf/lisp/weblisp/*.lisp")
(defparameter *fasl-path* "/home/emf/lisp/weblisp/fasl/*.x86f")

(defun compile-weblisp-file (file &optional force-compilation)
  (let* ((lisp-file (merge-pathnames file *source-path*))
         (fasl-file (merge-pathnames (pathname-name file)
                                     *fasl-path*)))
    (if (or force-compilation
            (not (probe-file fasl-file))
            (< (file-write-date fasl-file) (file-write-date lisp-file)))
        (multiple-value-bind (fas warn fail)
            (compile-file lisp-file :output-file fasl-file)
          (declare (ignorable fas warn))
          (if fail
              (format t "~&Compilation of ~A failed.~%" lisp-file)
              (load fasl-file)))
        (load fasl-file))))


(defun build-web (&optional (force-compilation nil))
  (dolist (file *weblisp-files*)
    (compile-weblisp-file file force-compilation)))

(defun start-web (&optional (force-compilation nil))
  (build-web force-compilation)
  (start-apache-listener)
  (start-scheduled-full-gc)
  (start-scheduled-explore-unknown-ips))

(defun restart-web ()
  (dolist (proc (butlast (mp:all-processes)))
    (mp:destroy-process proc)))


(defun scheduled-full-gc (&optional (interval (* 12 3600)))
  (loop (format t ";; Running full garbage collection.~%")
        (ext:gc :full t :verbose t)
        (sleep interval)))

(defun start-scheduled-full-gc ()
  (mp:make-process #'scheduled-full-gc :name "Scheduled Full GC"))

;;;===========================================================================
;;;
;;; Website management
;;;

(defun list-apache-addresses ()
  (format t "~%Address")
  (let ((i 0))
    (maphash (lambda (x y)
               (incf i)
               (let ((fn (page-function y)))
                 (format t "~%~A~30T" x)
                 (cond
                   ((not (functionp fn))
                    (format t "Static"))
                   ((compiled-function-p fn)
                    (format t "Compiled"))
                   (t
                    (format t "Interpreted")))))
             *apache-address-table*)
    (format t "~%~%Total ~D pages" i)))

(defun delete-apache-addresses (&rest addresses)
  (dolist (address addresses)
    (multiple-value-bind (page found)
        (gethash address *apache-address-table*)
      (declare (ignore page))
      (when found
        (format t "Deleting: ~A" address)
        (remhash address *apache-address-table*)))))

(defun test-apache-address (url &optional (command '()))
  (if-bind (pos (position #\? url))
      (setq command (cons (cons "url-query" (subseq url (1+ pos)))
                          command)
            url (subseq url 0 pos)))
  (if-bind (page (find-page url))
      (funcall (sub-page-function page) command)))