;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          project.lisp
;;;; Purpose:       Project handler for wol library
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  July 2003
;;;;
;;;; $Id: project.lisp,v 1.1 2003/07/16 16:02:21 kevin Exp $
;;;;
;;;; This file and Wol are Copyright (c) 2001-2003 by Kevin M. Rosenberg
;;;; *************************************************************************

(in-package #:wol)

(defun wol-project (name &key (project-prefix "/") map index
			      (sessions t) (session-lifetime 18000)
			      (reap-interval 300) (server *ml-server*))
  (unless server
    (warn "Can't start project without server")
    (return-from wol-project nil))
  
  (multiple-value-bind (project found) (gethash name *active-projects*)
    (unless found
      (setq project (make-instance 'wol-project))
      (setf (gethash name *active-projects*) project))
    
    (setf (project-name project) name)
    (setf (project-prefix project) project-prefix)
    (setf (project-map project) map)
    (setf (project-index project) index) 
    (setf (project-server project) server)
    (setf (lifetime (session-master project)) session-lifetime)
    (setf (cookie-name (session-master project)) name)

    (let ((hash (make-hash-table :size (length map) :test 'equal)))
      (dolist (map-item map)
	(setf (gethash (first map-item) hash) (second map-item)))
      (setf (project-hash-map project) hash))
    
    (setf (ml::processor server) 'wol-ml-processor)

    (if sessions
	(when (null (sessions (session-master project)))
	  (setf (sessions (session-master project))
	    (make-hash-table :test 'eq)))
      (when (sessions (session-master project))
	(setf (sessions (session-master project)) nil)))

    (setq *reap-interval* reap-interval)
    (when (and sessions (null *reaper-process*))
      (setq *reaper-process* (start-reaper)))))
    
(defun wol-ml-processor (command)
  "Processes an incoming modlisp command"
  (let ((req (command->request command
			       :ml-server *ml-server*)))
    (unless (dispatch-request req)
      (no-url-handler req))))


(defun command->request (command &key ml-server)
  "Convert a cl-modlisp command into a wol request"
  (let ((req
	 (make-instance 'http-request
	   :vhost (header-value command :host)
	   :raw-uri (header-value command :url)
	   :uri (create-uri (header-value command :host)
			    (awhen (header-value
				  command :server-ip-port)
				 (parse-integer it))
			    (header-value command :url))
	   :protocol (ensure-keyword (header-value command :server-protocol))
	   :protocol-string (header-value command :server-protocol)
	   :method (ensure-keyword (header-value command :method))
	   :posted-content (header-value command :posted-content)
	   :headers command
	   :socket *modlisp-socket*
	   :ml-server ml-server)))
    req))

(defun header-slot-value (req slot)
  (header-value (request-headers req) slot))

(defun create-uri (host port page)
  (format nil "http://~A:~D~A" host port page))

(defun is-index-request (req ent)
  (string= (request-raw-uri req) 
	   (project-prefix (entity-project ent))))

(defun dispatch-request (req)
  (let ((ent (find-entity-for-request req)))
    (when ent
      (let ((proj (entity-project ent)))
	(if (is-index-request req ent)
	    (progn
	      (redirect-to-location 
	       (format nil "~A~A" 
		       (project-prefix proj)
		       (project-index proj)))
	      t)
	  (progn
	    (request-decompile-uri req ent)
	    (compute-session req ent)
	    (dispatch-entity req ent))))
      ent)))

(defun make-entity (&key project)
  (make-instance 'entity :project project))

(defun find-entity-for-request (req)
  (maphash (lambda (name project)
	     (declare (ignore name))
	     (when (request-matches-prefix req (project-prefix project))
	       (return-from find-entity-for-request 
		 (make-entity :project project))))
	   *active-projects*))

(defun request-matches-prefix (req prefix)
  "Returns project if request matches project"
  (string-starts-with prefix (request-raw-uri req)))


(defun dispatch-entity (req ent)
  (let ((handler (request-find-handler req ent)))
    (if handler
	(handle-request handler req ent)
      (no-url-handler req))))

(defun request-find-handler (req ent)
  (nth-value 0 (gethash (request-page req) 
			(project-hash-map (entity-project ent)))))

(defun action-redirect (page req ent)
  (cmsg "redirect to ~A" page))
  
(defun handle-request (handler req ent)
  (typecase handler
    (null
     nil)
    ((or symbol function)
     (when (and (symbolp handler)
		(not (fboundp handler)))
       (cmsg "handler given a symbol without a function ~S" handler)
       (return-from handle-request nil))
     (let ((res (funcall handler req ent)))
       (typecase res
	 (string
	  (action-redirect res req ent))
	 (null
	  t)
	 (t
	  (cmsg "handler should return nil or a string"))))
     t)
    (string
     (cmsg "string handler not supported: ~A" handler)
     nil)
    (t
     (cmsg "unknown handler type: ~S" handler)
     nil)))

(defun no-url-handler (req)
  (print (request-socket req))
  (with-ml-page ()
    (html-stream
     *modlisp-socket*
     (:html
      (:head
       (:title "404 - NotFound"))
      (:body
       (:h1 "Not Found")
       (:p "The request for "
	   (:b (:write-string (request-uri req)))
	   " was not found on this server.")
       (:hr)
       (:div (:i "WOL "
		 (:write-string *wol-version*))))))))

  
(defun request-query (req &key (uri t) (post t))
  (append
    (when (and uri (request-uri-query req))
      (aif (request-query-alist req)
	 it
	 (setf (request-query-alist req)
	   (query-to-alist (request-uri-query req)))))
    (when (and post (request-posted-content req))
      (query-to-alist (request-posted-content req)))))

(defun websession-variable (ws name)
  (when ws
    (gethash name (websession-variables ws))))

(defun (setf websession-variable) (value ws name)
  (when ws
    (setf (gethash name (websession-variables ws)) value)))