Merged objcl into the main informatimago repository.
[com-informatimago:com-informatimago.git] / cl-posix / cliki / authed-cliki.lisp
1 (in-package :cliki)
2
3 ;; user auth, originally developed for entomotomy
4
5 (defstruct user name password)
6
7 (defmethod find-user ((cliki authed-cliki-handler) name)
8   (find name (cliki-users cliki)
9         :key #'user-name
10         :test #'string=))
11
12 (defmethod cliki-user-name ((cliki authed-cliki-handler) user)
13   (user-name user))
14
15 (defmethod cliki-user-cookie ((cliki authed-cliki-handler) user)
16   (format nil "auth-username=~A:~A; path=~A; expires=~A; domain=~A"
17           (urlstring-escape (user-name user))
18           (urlstring-escape (user-password user))
19           (url-path (cliki-url-root cliki))
20           "Sun, 01-Jun-2036 00:00:01 GMT"
21           (url-host (cliki-url-root cliki))))
22
23 (defun login-handler (request)
24   (let* ((cliki (request-cliki request))
25          (url (request-url request))
26          (body (request-body request))
27          (name (body-param "NAME" body))
28          (from (body-param "FROM" body))
29          (password (body-param "PASSWORD" body))
30          (user (find-user cliki name)))
31     (cond ((and user
32                 (string= password (user-password user)))
33            (request-send-headers request :set-cookie (cliki-user-cookie cliki user))
34            (request-redirect 
35             request (parse-urlstring from)
36             :set-cookie (cliki-user-cookie cliki user)))
37           (t (request-send-error request 401)))
38     (signal 'response-sent)))
39
40 (defmethod shared-initialize :after ((handler authed-cliki-handler)
41                                      slot-names &rest initargs)
42   (change-class (find-handler handler "edit/" nil)
43                 'authed-cliki-edit-handler)
44   (with-open-file (i (merge-pathnames
45                       (make-pathname :name "users" :type "dat"
46                                      :directory '(:relative "admin"))
47                       (cliki:cliki-data-directory handler)))
48     (let ((*package* #.*package*))
49       (setf (cliki-users handler) (read i))))
50   (install-handler handler 'login-handler "admin/login" nil))
51
52 (defmethod handle-request-authentication ((handler authed-cliki-edit-handler)
53                                          method request)
54   (let* ((u (request-cookie request "auth-username"))
55          (colon (position #\: u))
56          (username (urlstring-unescape (subseq u 0 colon)))
57          (password (and colon (urlstring-unescape (subseq u (1+ colon)))))
58          (cliki (cliki:request-cliki request))
59          (user (find-user cliki username)))
60     (unless (and username password user
61                  (string= password (user-password user)))
62       (request-send-headers request)
63       (princ
64        (html
65         `(html (head (title "Login"))
66           (body (h1 "Authentication required")
67            (p "We need you to provide a username and password before you can edit this page")
68            ,@(if password `((p "Incorrect password provided")))
69            ((form :method post :action
70                   ,(format nil "~Aadmin/login"
71                            (urlstring
72                             (cliki:cliki-url-root cliki))))
73             (p "Name " ((input :name :name :type :text :size 30)))
74             (p "Password"
75                ((input :name :password :type :text :size 30)))
76             (p ((input :name :from :type :hidden :value
77                        ,(urlstring (request-url request))))
78                ((input :name login :value "Login" :type submit)))))))
79        (request-stream request))
80       (signal 'response-sent))
81     (setf (request-user request) user)))