Hunchentoot & Postmodern Quicky

I have only been using hunchentoot and lisp seriously for a few months. I AM NO expert in lisp or hunchentoot so please feel free to correct and/or chastize me regarding anything in this little piece.

Firstly get everything you need installed! (Script to follow one day…)

The example website uses hunchentoot 1.0 and postmodern, I tried to include a variety of features that you would find on a average website, stuff like style sheets, javascript, images, some db integration and of course a kewl “made with lisp” logo from http://www.normal-null.de/lisp_logo.html.

The example has 2 pages for now, a login and home page with all the user and roles plumbing needed. The roles and user stuff comes form a postgresql database and we use postmodern to get to it. In a follow up piece I will add a biographical screen, displaying the data in a grid with all its parafinalia (editing, paging, search etc).

This piece is not for absolute newbie’s but for some one that has the basics of lisp and just wants to see hunchentoot and postmodern in action together.

For now I am only adding the code needed. I will keep on hacking away at it till it looks more like a tutorial.

The Lisp Code:

#|
;Just to get started run this lot in repl

(require 'hunchentoot)
(require 'cl-who)
(require 'postmodern)
(require 's-sql)
(require 'simple-date)

(defparameter *code-dir* "/home/phil/Development/dataxware/slp-x-packs/")


(defparameter *slp-server* (hunchentoot:start (make-instance 'hunchentoot:acceptor :port 8080)))

;I am sure this is a Bad Idea - but quick for now 
(defparameter *my-connection* (postmodern:connect-toplevel "howto" "postgres" "password" "localhost"))

|#


(in-package :cl-user)

(defpackage :h-how-to
  (:use :cl
    :hunchentoot
    :cl-who
    :postmodern)
  (:export :*code-dir*
	   :*message-log-pathname*))

(in-package :h-how-to)

(defparameter *code-dir* "/home/phil/Development/lisphowto/")

(defparameter *message-log-pathname* "/home/phil/Development/lisphowto/hunchentoot.log")

(setf *show-lisp-errors-p* t)


;Dispatch handlers
(push (create-static-file-dispatcher-and-handler "/stylesheet.css" (concatenate 'string *code-dir* "stylesheet.css"))
      *dispatch-table*)
(push (create-static-file-dispatcher-and-handler "/logo300x100.jpg" (concatenate 'string *code-dir* "logo300x100.jpg"))
      *dispatch-table*)
(push (create-static-file-dispatcher-and-handler "/javascript.js" (concatenate 'string *code-dir* "javascript.js"))
      *dispatch-table*)


(push (create-regex-dispatcher "^/login$" 'login)
      *dispatch-table*)

(push (create-regex-dispatcher "^/login.html$" 'login-page)
      *dispatch-table*)


;;Straight forward loging page
(defun login-page ( )
  (with-html-output-to-string (*standard-output*)
    (:html 
     (:head 
      (:link :rel "stylesheet" :type "text/css" :href "/stylesheet.css") 
      (:title (str (format nil "X-Ware - ~a" "Login")))
      (:meta :name "Author" :content "Data X-Ware: x@x.co.za")
      (:meta :name "Classification" :content "Lisp web based something"))
     (:body 
      (:table :style "width:100%;background-color:#E8E8E8;" :border 0 :cellpadding 0 :cellspacing 0
	      (:tr
	       (:td :style "font-family:sans-serif;font-weight:bold;vertical-align:bottom;"
		    (:a :href "http://www.normal-null.de/lisp_logo.html" :target "_blank" (:img :src "/logo300x100.jpg" 
                         :alt "http://www.normal-null.de/lisp_logo.html")))
	       (:td :class "headerclass" (str "Login"))))
	      
      (:div :style "width:100%;height:4px;background-color:black")
	 (:br)
	 (:br)
	 (:br)
	 (:br)
	 (:br)
	 (:form :action "/login" :method "get"
		
		(:table :align "center"  :border "0" :cellpadding "0" :cellspacing "0"
			(:tr
			 (:td "User Name")
			 (:td (:input :type "text" :name "user-name"  :value ""))
			 (:tr
			  (:td "Password")
			  (:td (:input :type "password" :name "password"  :value "")))
			 (:tr
			  (:td :colspan "2" :align "center"
			       (:input :type "submit" :value "Login"))))))
	 
	 (if (parameter "error")
	     (str "Login failed. Wrong password or user-name"))))))


(defun login ()
  (let ((user-row (car (query (:select '*  :from 'company_user :where (:= 'email_address (parameter "user-name"))))))
    (roles-row (reduce #'append (query (:select 'role  :from 'company_user_role :where (:= 'email_address (parameter "user-name")))))))
    (setf (session-value 'user-company) (nth 0 user-row))
    (setf (session-value 'user-email) (parameter "user-name"))
    (setf (session-value 'user-detail) (list (parameter "user-name") "" roles-row))
    (if (or (not (session-value 'user-company)) (equal (session-value 'user-company) ""))
	(redirect "/login.html?error=failed")
	(redirect "/home.html"))))


;;User & role plumbing (shamelessly hacked from http://myblog.rsynnott.com/2007/10/doing-more-with-hunchentoot-cl-server.html 

; Does this user have access to these roles?
(defun has-access (user-details required-roles)
(if required-roles
  (reduce #'(lambda (a b) (and a b))
               (mapcar #'(lambda (role) (find role (third user-details) :test #'equal))
                                 required-roles))
  nil))

; Get user details from session
(defmacro with-user-details (required-roles &body body)
  `(let ((user-details (session-value 'user-detail)))
     (if (and user-details 
	      (or (has-access user-details ,required-roles)
		  (not  ,required-roles)))
	 ,@body
	 (with-html-output-to-string (*standard-output*) 
	   (str "You're not allowed view this page")))))
	   


;;Templated/Master web page
(defmacro page-template (header &body body)
    `(with-html-output-to-string (*standard-output*)
       (:html 
	(:head 
	 (:link :rel "stylesheet" :type "text/css" :href "/stylesheet.css") 
	 (:title (str (format nil "X-Ware - ~a" ,header)))
       (:meta :name "Author" :content "Data X-Ware: x@x.co.za")
       (:meta :name "Classification" :content "Lisp web based something")
       (:meta :name "Description" :content "Lisp web based something")
       (:script :language "JavaScript" :type "text/javascript" :src "/javascript.js"))      
	(:body
 	 (:table :style "width:100%;background-color:#E8E8E8;" :border 0 :cellpadding 0 :cellspacing 0
	  (:tr
	   (:td :style "font-family:sans-serif;font-weight:bold;font-size:44px;vertical-align:bottom;"
		(:a :href "http://www.normal-null.de/lisp_logo.html" :target "_blank" (:img :src "/logo300x100.jpg" :alt "http://www.normal-null.de/lisp_logo.html")))
	   (:td :class "headerclass" (str ,header))))	   
	 (:div :style "width:100%;height:4px;background-color:black")
	 (:br)
	 (:div :width "1024px" 
	  (str ,@body))))))


;;Rap the template in EASY Handler
(defmacro defpage-easy-slp (name header uri parameter-list required-roles &body body)
  `(define-easy-handler (,name :uri ,uri
			       :default-request-type :both)
	 ,parameter-list
     (page-template ,header 
		      (with-user-details ,required-roles
			,@body))))



;;Use template easy handler combo to build home page
(defpage-easy-slp home "Home" "/home.html" nil '("Super" "All")
  (with-html-output-to-string (*standard-output*)
    (:htm 
     (:br)
     (:p :style "font-family:sans-serif;font-weight:bold;font-size:24px;vertical-align:bottom;color:#7979FF;text-align:center"
	 (str "Welcome to the Hunchentoot and Postmodern QUICKY!"))
     (:p :style "font-family:sans-serif;font-weight:bold;font-size:20px;vertical-align:bottom;;color:#A9A9FF;text-align:center"
	 (str "Once you have mastered time, you will understand how true it is that most people overestimate what they can accomplish in a year - and underestimate what they can achieve in a decade!") 
	 (:br)
	 (:br)
	 (str "Anthony Robbins")))))

Supporting db scripts:

DROP TABLE IF EXISTS company;
CREATE TABLE company (
company_name character varying NOT NULL default '',
contact_person character varying NOT NULL default '',
telephone_number character varying NOT NULL default '',
facsimile_number character varying NOT NULL default '',
email_address character varying NOT NULL default '',
physical_address character varying NOT NULL,
postal_address character varying NOT NULL,
active character varying default 'Yes',
CONSTRAINT company_key PRIMARY KEY (company_name)
) ;

INSERT INTO company (company_name, contact_person, telephone_number, facsimile_number, email_address, physical_address, postal_address)
VALUES('Company X','Person X', '1234' ,'1234', 'x@x.com', E'Address Line 1\nAddressline2\nAddres Line 3\nCode',E'Address Line 1\nAddressline2\nAddres Line 3\nCode');

DROP TABLE IF EXISTS company_user;
CREATE TABLE company_user (
company_name character varying NOT NULL default '',
first_name character varying NOT NULL default '',
surname character varying NOT NULL default '',
telephone_number character varying NOT NULL default '',
facsimile_number character varying NOT NULL default '',
email_address character varying NOT NULL default '',
password character varying NOT NULL default '',
active character varying default 'Yes',
CONSTRAINT company_user_key PRIMARY KEY (company_name,email_address)
) ;

INSERT INTO company_user (company_name, first_name ,surname, telephone_number, facsimile_number, email_address, password)
VALUES('Company X','X','Person','1234','1234','y@y.com','yyy');

DROP TABLE IF EXISTS company_user_role;
CREATE TABLE company_user_role (
company_name character varying NOT NULL default '',
email_address character varying NOT NULL default '',
role character varying NOT NULL default 'All',
CONSTRAINT company_user_role_key PRIMARY KEY (company_name,email_address,role)
) ;

INSERT INTO company_user_role (company_name,email_address,role)
VALUES('Company X','y@y.com','Super');

INSERT INTO company_user_role (company_name,email_address,role)
VALUES('Company X','y@y.com','All');

-- Table: biographical

DROP TABLE IF EXISTS biographical;
CREATE TABLE biographical
(
company_name character varying NOT NULL default '',
industry_number character varying NOT NULL,
id_number character varying,
surname character varying,
name character varying,
gender character varying NOT NULL,
race character varying NOT NULL,
nationality character varying NOT NULL,
country character varying NOT NULL,
province character varying NOT NULL,
town character varying NOT NULL,
occupational_category integer NOT NULL,
occupational_level character varying NOT NULL,
disabled character varying NOT NULL,
permanent character varying NOT NULL,
job_title character varying NOT NULL,
learner_apprentace character varying NOT NULL,
date_of_engagement date NOT NULL,
CONSTRAINT biographical_key PRIMARY KEY (industry_number)
)
WITH (OIDS=FALSE);
ALTER TABLE biographical OWNER TO postgres;

INSERT INTO biographical(company_name, industry_number, id_number, surname, name, gender, race, nationality, country, province, town, occupational_category, occupational_level, disabled, permanent, job_title, learner_apprentace, date_of_engagement)
VALUES ('Company X','1', '1', 'Surname 1', 'Name 1', 'Male', 'White', 'SA', 'South Africa', 'Kwa Zulu', 'Some Other Town', 1, 'F','No', 'Yes', 'Job Title 1', 'No', '01 Jan 2008');
INSERT INTO biographical(company_name, industry_number, id_number, surname, name, gender, race, nationality, country, province, town, occupational_category, occupational_level, disabled, permanent, job_title, learner_apprentace, date_of_engagement)
VALUES ('Company X','1.1', '1.1', 'Surname 1.1', 'Name 1.1', 'Male', 'White', 'SA', 'South Africa', 'Gauteng', 'My Town', 1, 'F','No', 'Yes', 'Job Title 1', 'No', '01 Jan 2008');

Advertisements

Tags: , , ,

2 Responses to “Hunchentoot & Postmodern Quicky”

  1. Bryan Emrys Says:

    Thought about how you are going to sanitize the parameter list?

  2. zaries Says:

    Nope I have not got any suggestions?

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s


%d bloggers like this: