summaryrefslogtreecommitdiff
path: root/mulkcms-hunchentoot.lisp
blob: 4300871d01e1131bfe37eab44b9264ee48a50a00 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
(in-package #:mulkcms-hunchentoot)

(defvar *acceptor*)

(defun dispatch-static-file-request (request)
  (let* ((relative-path (subseq (script-name request) 1))
         (file (merge-pathnames relative-path *static-files*)))
    (and (probe-file file)
         ;; For security (otherwise paths like "/../mulkcms.lisp" or
         ;; "//boot/initrd.img" would be handled by sending the
         ;; requested file...):
         (starts-with-subseq (namestring (truename *static-files*))
                             (namestring (truename file)))
         (not (directory-pathname-p file))
         (lambda () (handle-static-file file)))))

(defun handle-authorization-page ()
  (hunchentoot:require-authorization "MulkCMS"))

(defun dispatch-mulkcms-request (request)
  (let* ((relative-path (subseq (script-name request) 1))
         (mulkcms::*use-ssl-p* (equal (header-in* :x-use-ssl)
                                      "true"))
         (mulkcms::*real-remote-addr*
          (hunchentoot:real-remote-addr))
         (mulkcms::*user-agent*
          (hunchentoot:user-agent))
         (mulkcms::*request-method*
          (hunchentoot:request-method*))
         (mulkcms::*headers*
          (hunchentoot::headers-in*)))
    (multiple-value-bind
          (mulkcms::*user-name* mulkcms::*password*)
        (hunchentoot:authorization)
      (let ((handler (mulkcms::find-request-handler relative-path
                                                    (append (get-parameters*)
                                                            (post-parameters*))
                                                    (header-in* :accept-language))))
        (and handler
             (lambda ()
               (let ((result (funcall handler)))
                 (typecase result
                   (cons
                    (when-let (content-type (getf result :content-type))
                      (setf (hunchentoot:content-type*) content-type))
                    (when-let (headers (getf result :headers))
                      (dolist (header headers)
                        (setf (hunchentoot:header-out (car header))
                              (cdr header))))
                    (when-let (return-code (getf result :return-code))
                      (setf (hunchentoot:return-code*) return-code)
                      ;;(hunchentoot:abort-request-handler)
                      )
                    (getf result :body))
                   (t
                    result)))))))))

(defun setup-handlers ()
  (setq *dispatch-table*
        (list* 'dispatch-mulkcms-request
               'dispatch-static-file-request
               *dispatch-table*))
  (setq *default-handler*
        (lambda ()
          (setf (return-code*) +http-not-found+))))

(defun start-server ()
  (setq hunchentoot:*hunchentoot-default-external-format*
        (flexi-streams:make-external-format :utf-8))
  (setq hunchentoot:*default-content-type*
        "text/html; charset=utf-8")
  (setup-handlers)
  (setq *random-state* (make-random-state t))
  (setq *acceptor* (make-instance 'hunchentoot:easy-acceptor
                      :port *server-port*
                      :address *server-address*))
  (setq mulkcms::*authorization-page-handler* #'handle-authorization-page)
  (hunchentoot:start *acceptor*))