Commit 8c420d47 authored by Bas Lijnse's avatar Bas Lijnse

Added an example CGI application that uses the relational mapper with a mysql database.

git-svn-id: https://svn.cs.ru.nl/repos/clean-platform/trunk@53 2afc29ad-3112-4e41-907a-9359c7e6e986
parent fce6ce50
......@@ -7,6 +7,7 @@ Environments
Path: {Application}\Platform\src\libraries\OS-Independent
Path: {Application}\Platform\src\libraries\OS-Independent\Data
Path: {Application}\Platform\src\libraries\OS-Independent\Database
Path: {Application}\Platform\src\libraries\OS-Independent\Database\SQL
Path: {Application}\Platform\src\libraries\OS-Independent\GUI
Path: {Application}\Platform\src\libraries\OS-Independent\Internet
Path: {Application}\Platform\src\libraries\OS-Independent\Internet\HTTP
......
body {
background-color: #fff;
margin: 0px;
font-family: Verdana, Arial, sans-serif;
}
a {
color: #ff9933;
text-decoration: none;
}
a:hover {
text-decoration: underline;
}
img {
border: none;
}
#main-menu {
position: absolute;
top: 110px;
left: 20px;
height: 30px;
width: 100px;
text-align: right;
}
#main-menu a {
display: block;
color: #999;
text-decoration: none;
}
#main-title {
position: absolute;
top: 60px;
left: 145px;
height: 50px;
}
#main-title h1 {
margin: 0px;
font-family: "Trebuchet MS",Verdana, sans-serif;
color: #000;
}
#main-content {
position: absolute;
top: 110px;
left: 135px;
width: 600px;
font-size: 12px;
border: dashed #ccc;
border-width: 0px 1px 0px 1px;
padding: 0px 10px 100px 10px;
}
#main-message {
background-color: #D6F5E0;
border: 1px dashed #5CD685;
padding: 5px;
margin-bottom: 5px;
font-style: italic;
}
#main-message img {
margin-right: 5px;
position: relative;
top: 3px;
}
table.pm-formlayout {
width: 100%;
margin-bottom: 10px;
}
table.pm-formlayout th {
background-color: #ff9933;
color: #fff;
width: 150px;
text-align: left;
padding: 2px;
vertical-align: top;
}
table.pm-formlayout td {
background-color: #eee;
padding: 2px;
}
table.pm-table {
width: 100%;
border-spacing: 0px;
background-color: #fff;
}
table.pm-table tr {
}
table.pm-table th {
background-color: #ccc;
color: #fff;
text-align: left;
border: 2px solid;
border-color: #ddd #bbb #bbb #ddd;
}
table.pm-table td {
border: solid #999;
border-width: 0px 0px 1px 0px;
}
div.pm-addrow {
padding: 2px;
}
div.pm-addrow img {
position: relative;
top: 2px;
margin-right: 5px;
}
div.pm-toolbar {
text-align: right;
padding: 2px 0px 2px 0px;
margin: 0px 0px 5px 0px;
}
fieldset.pm-fieldset legend {
font-weight: bold;
}
table.pm-subset {
width: 300px;
text-align: center;
}
table.pm-subset th {
color: #000;
background-color: transparent;
}
table.pm-subset select {
width: 100%;
}
button img {
margin-right: 5px;
position: relative;
top: 3px;
}
This diff is collapsed.
var taskCounter = -1;
function subset_select(name) {
var left = document.getElementById(name + '-left');
var right = document.getElementById(name + '-right');
var value = document.getElementById(name + '-value');
subset_transfer(left,right);
subset_setvalue(right,value);
}
function subset_deselect(name) {
var left = document.getElementById(name + '-left');
var right = document.getElementById(name + '-right');
var value = document.getElementById(name + '-value');
subset_transfer(right,left);
subset_setvalue(right, value);
}
function subset_transfer(from, to) {
for(var i = 0; i < from.options.length; i++) {
if(from.options[i].selected) {
to.options[to.options.length] = new Option (from.options[i].text,from.options[i].value);
}
}
for(var i = from.options.length - 1; i >= 0; i--) {
if(from.options[i].selected) {
from.remove(i);
}
}
}
function subset_setvalue(from, to) {
var vals = new Array();
for(var i = 0; i < from.options.length; i++) {
vals[vals.length] = from.options[i].value;
}
to.value = vals.join("-");
}
function addTask(el) {
var div = el;
while (div.tagName != "DIV") {
div = div.parentNode;
}
var table = div.previousSibling;
var tbody = table.getElementsByTagName("TBODY")[0];
var row = document.createElement("tr");
var td1 = document.createElement("td");
var td1a = document.createElement("a");
var td1img = document.createElement("img");
td1img.src = "/icons/delete.png"
td1img.alt = "Remove";
td1a.href = "#";
td1a.onclick = function () {delTask(this);};
td1a.appendChild(td1img);
td1.appendChild(td1a);
var td2 = document.createElement("td");
td2.innerHTML = "-";
var td3 = document.createElement("td");
var td3ipt = document.createElement("input");
td3ipt.name = "task_description-" + taskCounter;
td3ipt.class = "pm-string";
td3.appendChild(td3ipt);
var td4 = document.createElement("td");
var td4ipt = document.createElement("input");
td4ipt.type = "checkbox";
td4ipt.name = "task_done-" + taskCounter;
td4ipt.class = "pm-bool";
td4ipt.value = "True";
td4.appendChild(td4ipt);
row.appendChild(td1);
row.appendChild(td2);
row.appendChild(td3);
row.appendChild(td4);
tbody.appendChild(row);
taskCounter -= 1;
}
function delTask(el) {
var row = el;
while (row.tagName != "TR") {
row = row.parentNode;
}
row.parentNode.removeChild(row);
return false;
}
DROP TABLE IF EXISTS projectworkers;
DROP TABLE IF EXISTS task;
DROP TABLE IF EXISTS project;
DROP TABLE IF EXISTS employee;
CREATE TABLE employee (
name varchar(255) NOT NULL,
description varchar(255) NOT NULL,
PRIMARY KEY(name)
) ENGINE=InnoDB;
CREATE TABLE project (
projectNr int NOT NULL auto_increment,
description varchar(255) NOT NULL,
parent int NULL,
PRIMARY KEY(projectNr),
FOREIGN KEY(parent) REFERENCES project (projectNr)
) ENGINE=InnoDB;
CREATE TABLE projectworkers (
employee varchar(255) NOT NULL,
project int NOT NULL,
PRIMARY KEY(employee,project),
FOREIGN KEY(employee) REFERENCES employee (name),
FOREIGN KEY(project) REFERENCES project (projectNr)
) ENGINE=InnoDB;
CREATE TABLE task (
taskNr int NOT NULL auto_increment,
project int NOT NULL,
description varchar(255) NOT NULL,
done tinyint NOT NULL,
PRIMARY KEY(taskNr),
FOREIGN KEY(project) REFERENCES project (projectNr)
) ENGINE=InnoDB;
definition module PMDataModel
import Maybe
:: Employee = { employee_name :: String
, employee_description :: String
, projectworkers_project_ofwhich_employee :: [ProjectID]
}
:: EmployeeID = { employee_name :: String
}
:: Project = { project_projectNr :: Int
, project_description :: String
, project_parent :: (Maybe ProjectID)
, task_ofwhich_project :: [Task]
, project_ofwhich_parent :: [ProjectID]
, projectworkers_employee_ofwhich_project :: [EmployeeID]
}
:: ProjectID = { project_projectNr :: Int
}
:: Task = { task_taskNr :: Int
, task_project :: ProjectID
, task_description :: String
, task_done :: Bool
}
:: TaskID = { task_taskNr :: Int
}
implementation module PMDataModel
import Maybe
\ No newline at end of file
definition module PMDatabase
import StdEnv, Maybe
import SQL, MySQL
import PMDataModel
//Database initialization and finalization
initDatabase :: !String !String !String !String !*World -> (!*MySQLContext, !*MySQLConnection, !*MySQLCursor, *World)
endDatabase :: !*MySQLContext !*MySQLConnection !*MySQLCursor !*World -> *World
//Example of manually written database operation
updateProject :: Project !*cur -> (Maybe SQLError, *cur) | SQLCursor cur
implementation module PMDatabase
import StdEnv, Maybe
import SQL, MySQL
import Text
import PMDataModel
initDatabase :: !String !String !String !String !*World -> (!*MySQLContext, !*MySQLConnection, !*MySQLCursor, *World)
initDatabase hostname username password database world
# (mbErr,mbContext,world) = openContext world
| isJust mbErr = abort "Failed to initialize database library"
# context = fromJust mbContext
# (mbErr,mbConn,context) = openConnection hostname username password database context
| isJust mbErr = abort ("Failed to connect to database: " +++ toString (fromJust mbErr))
# connection = fromJust mbConn
# (mbErr,mbCursor,connection) = openCursor connection
| isJust mbErr = abort ("Failed to open database cursor: " +++ toString (fromJust mbErr))
# cursor = fromJust mbCursor
= (context,connection,cursor,world)
endDatabase :: !*MySQLContext !*MySQLConnection !*MySQLCursor !*World -> *World
endDatabase context connection cursor world
# (_,connection) = closeCursor cursor connection
# (_,context) = closeConnection connection context
# (_,world) = closeContext context world
= world
//Boring function we do no longer have to write
updateProject :: Project !*cur -> (Maybe SQLError, *cur) | SQLCursor cur
updateProject project =: {Project | project_projectNr = pid} cursor
//Update the project record
# (mbErr,cursor) = execute "UPDATE project SET description = ?, parent = ? WHERE projectNr = ?" pvalues cursor
| isJust mbErr = (mbErr, cursor)
//Update/create the linked employees
# (mbErr, ids, cursor) = linkEmployees project.projectworkers_employee_ofwhich_project cursor
| isJust mbErr = (mbErr, cursor)
//Garbage collect linked employees
# (mbErr,cursor) = execute ("DELETE FROM projectworkers WHERE project = ?" +++ ematch ids) (evalues ids) cursor
| isJust mbErr = (mbErr, cursor)
//Update/add the tasks
# (mbErr,ids,cursor) = updateTasks project.task_ofwhich_project cursor
| isJust mbErr = (mbErr, cursor)
//Garbage collect tasks
# (mbErr,cursor) = execute ("DELETE FROM task WHERE project = ?" +++ tmatch ids) (tvalues ids) cursor
| isJust mbErr = (mbErr, cursor)
= (Nothing, cursor)
where
pvalues = [SQLVVarchar project.project_description, pparent project.project_parent, SQLVInteger project.Project.project_projectNr]
pparent Nothing = SQLVNull
pparent (Just {ProjectID| project_projectNr = x}) = SQLVInteger x
linkEmployees [] cursor = (Nothing, [], cursor)
linkEmployees [{EmployeeID | employee_name = e}:es] cursor
# (mbErr, cursor) = execute "SELECT * FROM projectworkers WHERE project = ? AND employee = ?" [SQLVInteger pid, SQLVVarchar e] cursor
| isJust mbErr = (mbErr,[],cursor)
# (mbErr, num, cursor) = numRows cursor
| num == 0
# (mbErr, cursor) = execute "INSERT INTO projectworkers (project,employee) VALUES (?,?)" [SQLVInteger pid, SQLVVarchar e] cursor
| isJust mbErr = (mbErr,[],cursor)
# (mbErr,ids,cursor) = linkEmployees es cursor
= (mbErr,[e:ids],cursor)
| otherwise
# (mbErr,ids,cursor) = linkEmployees es cursor
= (mbErr,[e:ids],cursor)
ematch [] = ""
ematch ids = " AND NOT (employee IN (" +++ (join "," ["?" \\ x <- ids]) +++ "))"
evalues ids = [SQLVInteger pid: map SQLVVarchar ids]
updateTasks [] cursor = (Nothing, [], cursor)
updateTasks [{Task | task_taskNr = taskNr, task_description = description, task_done = done}:ts] cursor
| taskNr == 0
# vals = [SQLVVarchar description, SQLVInteger (if done 1 0), SQLVInteger pid]
# (mbErr, cursor) = execute "INSERT INTO task (description,done,project) VALUES (?,?,?)" vals cursor
| isJust mbErr = (mbErr, [], cursor)
# (mbErr, i, cursor) = insertId cursor
| isJust mbErr = (mbErr, [], cursor)
# (mbErr, ids, cursor) = updateTasks ts cursor
= (mbErr, [i:ids], cursor)
| otherwise
# vals = [SQLVVarchar description,SQLVInteger (if done 1 0),SQLVInteger pid,SQLVInteger taskNr]
# (mbErr, cursor) = execute "UPDATE task SET description = ?, done = ?, project = ? WHERE taskNr = ? " vals cursor
| isJust mbErr = (mbErr, [], cursor)
# (mbErr, ids, cursor) = updateTasks ts cursor
= (mbErr, [taskNr:ids], cursor)
tmatch [] = ""
tmatch ids = " AND NOT (taskNr IN (" +++ (join "," ["?" \\ x <- ids]) +++ "))"
tvalues ids = map SQLVInteger [pid:ids]
definition module PMForms
import PMHtml, PMDataModel
import HTTP, Map
showProjectForm :: Project -> HtmlTag
editProjectForm :: Bool Project [ProjectID] [EmployeeID] -> HtmlTag
editProjectUpd :: (Map String String) -> Project
showEmployeeForm :: Employee -> HtmlTag
editEmployeeForm :: Bool Employee [ProjectID] -> HtmlTag
editEmployeeUpd ::(Map String String) -> Employee
implementation module PMForms
import PMHtml, PMDataModel
import StdList, StdEnum, StdArray
import HTTP, Text
showProjectForm :: Project -> HtmlTag
showProjectForm p = DivTag [] [ shortinfo, makeFieldSet "Tasks" [tasks] ]
where
shortinfo = makeFormLayout (zip2 labels fields)
labels = ["Project nr","Description","Parent project","Child projects", "Assigned employees"]
fields = [[Text (toString p.Project.project_projectNr)],[Text p.project_description],[parent],children,employees]
parent = case p.Project.project_parent of
Nothing = Text "-"
Just {ProjectID|project_projectNr = pid} = ATag [HrefAttr ("/projects/" +++ toString pid)] [Text (toString pid)]
children = joinHtml (Text ", ") [ATag [HrefAttr ("/projects/" +++ toString pid)] [Text (toString pid)] \\ {ProjectID | project_projectNr = pid} <- p.project_ofwhich_parent]
employees = joinHtml (Text ", ") [ATag [HrefAttr ("/employees/" +++ name)] [Text name] \\ {EmployeeID | employee_name = name} <- p.projectworkers_employee_ofwhich_project]
tasks = makeTable ["Task Nr","Description","Done"] [[Text (toString t.Task.task_taskNr),Text t.Task.task_description, makeDoneIcon t.Task.task_done] \\ t <- p.task_ofwhich_project]
editProjectForm :: Bool Project [ProjectID] [EmployeeID] -> HtmlTag
editProjectForm create project projects employees = makeForm (if create "+add" "+edit") [content,makeFieldSet "Tasks" tasks,buttons]
where
content = makeFormLayout (zip2 labels fields)
labels = ["Project Nr","Description","Parent project","Child projects", "Assigned employees"]
fields = [ [Text (if create "-" (toString project.Project.project_projectNr)), makeHiddenInput "project_projectNr" project.Project.project_projectNr]
, [makeStringInput "project_description" project.Project.project_description]
, [makeIntSelect "project_parent" parent [(p,toString p) \\ {ProjectID|project_projectNr = p} <- projects | p <> project.Project.project_projectNr]]
, [Text (join ", " children), makeHiddenInput "project_ofwhich_parent" (join "-" children)]
, [makeSubsetInput "projectworkers_employee_ofwhich_project"
[e.EmployeeID.employee_name \\ e <- employees]
[e.EmployeeID.employee_name \\ e <- project.Project.projectworkers_employee_ofwhich_project]]
]
children =[toString pid \\ {ProjectID | project_projectNr = pid} <- project.project_ofwhich_parent]
tasks = [makeTable ["","Task Nr","Description","Done"]
[[ ATag [HrefAttr "#", OnclickAttr "delTask(this);"] [ImgTag [SrcAttr "/icons/delete.png", AltAttr "Remove"]]
, Text (toString t.Task.task_taskNr)
, makeStringInput ("task_description-" +++ toString t.Task.task_taskNr) t.Task.task_description
, makeBoolInput ("task_done-" +++ toString t.Task.task_taskNr) t.Task.task_done]
\\ t <- project.task_ofwhich_project]
,DivTag [ClassAttr "pm-addrow"] [ATag [HrefAttr "#", OnclickAttr "addTask(this);"] [ImgTag [SrcAttr "/icons/add.png", AltAttr "Remove"]],ATag [HrefAttr "#", OnclickAttr "addTask(this);"] [Text "Add another task"]]
]
parent = case project.project_parent of
Nothing = 0
Just {ProjectID| project_projectNr = x} = x
buttons = makeToolbar [makeLinkButton "Cancel" "." (Just "cross"), makeSubmitButton "Ok" (Just "tick")]
editProjectUpd :: (Map String String) -> Project
editProjectUpd args
# pid = maybe 0 toInt (get "project_projectNr" args)
# parent = maybe 0 toInt (get "project_parent" args)
# children = get "project_ofwhich_parent" args
# children = maybe [] (split "-") children
# children = [{ProjectID | project_projectNr = toInt pid} \\ pid <- children]
# employees = get "projectworkers_employee_ofwhich_project" args
# employees = maybe [] (split "-") employees
# employees = [{EmployeeID | employee_name = name} \\ name <- employees | name <> ""]
# tasks = [ t \\ Just t <- map (makeTask pid args) (toList args)]
= { project_projectNr = maybe 0 toInt (get "project_projectNr" args)
, project_description = maybe "" id (get "project_description" args)
, project_parent = if (parent <> 0) (Just {ProjectID| project_projectNr = parent}) Nothing
, project_ofwhich_parent = children
, task_ofwhich_project = tasks
, projectworkers_employee_ofwhich_project = employees
}
where
makeTask :: Int (Map String String) (String,String) -> Maybe Task
makeTask pid args (name,value)
| name % (0,15) <> "task_description" = Nothing
# taskNr = toInt (name % (17,size name))
# done = isJust (get ("task_done-" +++ toString taskNr) args)
= Just ({Task | task_taskNr = (if (taskNr < 0) 0 taskNr), task_description = value, task_project = {ProjectID | project_projectNr = pid}, task_done = done})
showEmployeeForm :: Employee -> HtmlTag
showEmployeeForm e = makeFormLayout (zip2 labels fields)
where
labels = ["Name","Description","Works on projects"]
fields = [[Text e.Employee.employee_name], [Text e.employee_description], projects]
projects = joinHtml (Text ", ")[ ATag [HrefAttr ("/projects/" +++ toString pid)]
[Text (toString pid)] \\ {ProjectID | project_projectNr = pid} <- e.projectworkers_project_ofwhich_employee]
editEmployeeForm :: Bool Employee [ProjectID] -> HtmlTag
editEmployeeForm create employee projects = makeForm (if create "+add" "+edit") [content, buttons]
where
content = makeFormLayout (zip2 labels fields)
buttons = makeToolbar [makeLinkButton "Cancel" "." (Just "cross"), makeSubmitButton "Ok" (Just "tick")]
labels = ["Name","Description","Works on projects"]
fields = [ if create [makeStringInput "employee_name" employee.Employee.employee_name] [SpanTag [] [Text employee.Employee.employee_name,makeHiddenInput "employee_name" employee.Employee.employee_name]]
, [makeStringInput "employee_description" employee.Employee.employee_description]
, [makeSubsetInput "projectworkers_project_ofwhich_employee"
[toString p.ProjectID.project_projectNr \\ p <- projects]
[toString p.ProjectID.project_projectNr \\ p <- employee.Employee.projectworkers_project_ofwhich_employee]]
]
editEmployeeUpd :: (Map String String) -> Employee
editEmployeeUpd args
# projects = get "projectworkers_project_ofwhich_employee" args
# projects = maybe [] (split "-") projects
# projects = [{ProjectID | project_projectNr = toInt pid} \\ pid <- projects | toInt pid > 0]
= { employee_name = maybe "" id (get "employee_name" args)
, employee_description = maybe "" id (get "employee_description" args)
, projectworkers_project_ofwhich_employee = projects
}
instance fromString Bool
where
fromString "True" = True
fromString _ = False
definition module PMHtml
import HTML, Maybe
makePage :: String String [HtmlTag] -> HtmlTag
makeForm :: String [HtmlTag] -> HtmlTag
makeTable :: [String] [[HtmlTag]] -> HtmlTag
makeFormLayout :: [(String,[HtmlTag])] -> HtmlTag
makeFieldSet :: String [HtmlTag] -> HtmlTag
makeToolbar :: [HtmlTag] -> HtmlTag
makeLinkButton :: String String (Maybe String) -> HtmlTag
makeSubmitButton :: String (Maybe String) -> HtmlTag
makeIntInput :: String Int -> HtmlTag
makeBoolInput :: String Bool -> HtmlTag
makeStringInput :: String String -> HtmlTag
makeHiddenInput :: String a -> HtmlTag | toString a
makeSubsetInput :: String [String] [String] -> HtmlTag
makeIntSelect :: String Int [(Int,String)] -> HtmlTag
joinHtml :: HtmlTag [HtmlTag] -> [HtmlTag]
makeDoneIcon :: Bool -> HtmlTag
implementation module PMHtml
import StdList
import HTML, Text, Maybe
makePage :: String String [HtmlTag] -> HtmlTag
makePage title message content
= HtmlTag [] [HeadTag [] head, BodyTag [] body]
where
head = [ TitleTag [] [Text title]
, LinkTag [RelAttr "stylesheet", HrefAttr "/PM.css", TypeAttr "text/css"] []
, ScriptTag [SrcAttr "/PM.js", TypeAttr "text/javascript"] []
]
body = [ DivTag [IdAttr "main-title"] [H1Tag [] [Text title]]
, DivTag [IdAttr "main-menu"] makeMenu
, DivTag [IdAttr "main-content"] (msg ++ content)
]
msg = if (message <> "") [DivTag [IdAttr "main-message"] [ImgTag [SrcAttr "/icons/information.png"],Text message]] []
makeMenu :: [HtmlTag]
makeMenu = [ATag [HrefAttr link] [Text title] \\ (title, link) <- items]
where
items = [("Projects","/projects"),("Employees","/employees")]
makeForm :: String [HtmlTag] -> HtmlTag
makeForm action content = FormTag [ActionAttr action, MethodAttr "post"] content
makeTable :: [String] [[HtmlTag]] -> HtmlTag
makeTable headers rows = TableTag [ClassAttr "pm-table"] [head:body]
where
head = TrTag [] [ThTag [] [Text th] \\ th <- headers]
body = [TrTag [] [TdTag [] [td] \\ td <- row] \\ row <- rows ]
makeFormLayout :: [(String,[HtmlTag])] -> HtmlTag
makeFormLayout rows = TableTag [ClassAttr "pm-formlayout"] content
where
content = [TrTag [] [ThTag [] [Text label], TdTag [] field] \\ (label,field) <- rows]
makeFieldSet :: String [HtmlTag] -> HtmlTag
makeFieldSet title content
= FieldsetTag [ClassAttr "pm-fieldset"] [LegendTag [] [Text title] : content]
makeToolbar :: [HtmlTag] -> HtmlTag
makeToolbar content = DivTag [ClassAttr "pm-toolbar"] content
makeLinkButton :: String String (Maybe String) -> HtmlTag
makeLinkButton label href icon
= ButtonTag [OnclickAttr ("window.location='" +++ href +++ "'; return false;")] ((icontag icon)++ [Text label])
where