This is a basic implementation of user management in QM.
Rebol [
title: "Base QM Sessions Model"
type: 'roughcut
]
locate: func [id [tuple!]][replace/all form id "." "-"]
record: make record [
on-create: does [
; probe join [OnCreate] copy owner
until [
not find head owner set 'id random 100.100.100.100.100.100
]
set 'created now/precise
]
on-save: does [
set 'last-activity now/precise
]
age?: does [
difference now/precise get 'created
]
last-use?: does [
difference now/precise get 'last-activity
]
expired?: does [
config/session-timeout < last-use?
]
as-cookie: does [form get 'id]
]
Rebol [
Title: "Base QM Users Model"
Type: 'roughcut
Roles: [
participant "contribute to discussions"
editor "edit content"
moderator "manage Users"
]
]
record: make record [
on-create: does [
set 'valikey random 100.100.100.100.100.100
set 'groups []
set 'roles [pending]
set 'signup now
]
on-save: does [
if empty? head owner [set 'owner true]
any [
is-hashed-password? get 'password
set 'password to-sha1-password config/private-key get 'password
]
set 'last-activity now/precise
]
as-cookie: does [
rejoin [get 'id "/" get 'valikey]
]
valid-key?: func [key][
equal? get 'valikey as tuple! key
]
valid-pass?: func [pass [string!]][
all [
any [
is-hashed-password? pass
pass: to-sha1-password config/private-key pass
]
equal? get 'password pass
]
]
initialize: injects [
id: string! [1 chars-a 1 30 [chars-an | #"-"]]
else {Not a valid user name}
email: email!
else {This site requires a valid email address to register}
password: string! length is between [6 20]
else {Password should be between 6 and 20 characters}
is confirmed by :confirmation
else {Passwords do not match}
]
update: func [details /owner /moderator /me][
if all [
block? details
details: import/report-to details case [
owner [compose [(credentials) (permissions)]]
me [credentials]
moderator [permissions]
] errors
][
case/all [
select details 'email [set 'email details/email]
select details 'password [set 'password details/password]
find details 'roles [set 'roles get-roles details/roles]
]
store
]
]
has-role?: func [role][
any [
get 'owner
found? find envelope get 'roles role
]
]
belongs-to?: func [group][
found? find get 'groups group
]
]
roles: header/roles
;-- update helpers
credentials: [
email: email!
else {Valid email address required}
password: opt string! length is between [6 20]
else {Password should be between 6 and 20 characters}
is confirmed by :confirmation
else {Passwords do not match}
]
permissions: [roles: opt block!]
get-roles: func [roles][
extract remove-each [role value] any [roles []][value <> "yes"] 2
]
;-- password helpers
clean-hash-string: func [hash][enbase/base hash 16]
is-hashed-password?: func [password /local hash-type][
hash-type: false
parse password [#"$" copy hash-type ["md5" | "sha1"] #"$" to end]
hash-type
]
to-sha1-password: func [salt pass][
pass: checksum/secure join pass salt
join "$sha1$" clean-hash-string pass
]
Rebol [
Title: "QM Environment"
Type: 'controller
]
event "web-start" does [
session: user: none
; purge sessions
foreach session select sessions [expired?][session/destroy]
; initialize sessions
unless all [
session: as tuple! get-cookie "ssn"
session: select sessions session
][
session: select sessions 'new
set-cookie "ssn" session/as-cookie
]
session/store
; initialize users
unless use [user-key][
all [
user: get-cookie "usr"
set [user user-key] parse user "/"
user: select users user
user/valid-key? user-key
]
][
clear-cookie "usr"
user: select users 'new
]
]
Rebol [
Title: "User Account Controller"
Type: 'controller
Default: "sign-in"
Template: %templates/qm.rsp
]
event "prepare" does [
id: reason: target: prospect: details: none
is-moderator: user/has-role? 'moderator
is-owner: user/get 'owner
is-target: none
raise: func [msg sts][render/status rejoin ["<h2>" msg "</h2>"] sts]
]
protect "list" (not is-moderator) [
redirect-to %/user/sign-in
]
action "list" [page: opt integer!] does [
page: paginate users page
]
action "sign-up" does [
prospect: select users 'new
]
action "register" does [
prospect: select users 'new
either prospect/initialize get-param/body 'prospect [
prospect/store
set-cookie/expires "usr" prospect/as-cookie now + 366
redirect-to user/profile/(prospect/id)
][
render %sign-up.rsp
]
]
action "sign-in" does [
if assert-all [
id: get-param/body 'user/id [
target: select users 'new
]
target: select users id [
target: select users 'new
target/set 'id id
target/errors: [id [{Can't log you in with these credentials.}]]
]
target/valid-pass? get-param 'user/password [
target/errors: [password [{Can't log you in with these credentials}]]
]
][
set-cookie/expires "usr" target/as-cookie now + 366
redirect-to user/profile/(target/id)
]
]
action "sign-out" does [
session/destroy
clear-cookie "ssn"
clear-cookie "usr"
redirect-to %/user/sign-in
]
action "profile" [id: opt string!] does [
target: select users id
assert-all [
target [raise "Not Found" 404]
any [is-target: user/id = target/id is-moderator][
raise "Not Authorized" 403
]
]
]
action "update" [id: string!] does [
target: select users id
details: get-param 'target
if assert-all [
target [raise "Not Found" 404]
any [is-target: user/id = target/id is-moderator][
raise "Not Authorized" 403
]
case [
is-owner [target/update/owner details]
is-target [target/update/me details]
is-moderator [target/update/moderator details]
][render %profile.rsp]
][
redirect-to user/profile/(target/id)
]
]
protect "destroy" (not is-owner) [
raise "Not Authorized" 403
]
action "destroy" [id: string!] does [
target: select users id
either all [
target
not target/get 'owner
][
target/destroy
redirect-to %/user/list
][
raise "Not Found" 404
]
]
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en">
<head><title><%= title %></title>
<link rel="stylesheet" type="text/css" href="http://www.ross-gill.com/styles/qm.css" />
</head>
<body bgcolor="white">
<div class="image"><img width="280" height="150" src="/images/qm.png" alt="-QM-" /></div>
<h1><%= title %></h1>
<%= yield %>
<p><a href="http://www.ross-gill.com/QM/">QM</a> | <% either user/id [
%><%= user/id %>: <%! a user/profile/(user/id) %>Profile</a>, <%! a %/user/sign-out %>Sign Out</a><%
][
%><%! a %/user/sign-in %>Sign In</a><%
] %> | <a href="/wiki">Wiki</a> | <a href="/journal">Journal</a></p>
<p>Controller: <%= controller %>; Action: <%= action %></p>
</body></html>
<h2>Register</h2>
<%! form post %/user/register %><fieldset>
<legend>Create Username and Password</legend><% unless empty? prospect/errors [ %>
<ul><% foreach [key err] prospect/errors [ %>
<li><%= err/1 %></li><% ] %>
</ul><% ] %>
<table><tr>
<th><label for="prospect.id">Name:</label></th>
<td><%! field prospect/id (prospect/get 'id) %></td>
</tr><tr>
<th><label for="prospect.email">Email:</label></th>
<td><%! field prospect/email (prospect/get 'email) %></td>
</tr><tr>
<th><label for="prospect.password">Password:</label></th>
<td><%! password prospect/password %></td>
</tr><tr>
<th><label for="prospect.confirmation">Confirmation:</label></th>
<td><%! password prospect/confirmation %></td>
</tr><tr>
<td></td>
<td><%! submit do "Register" %>
</tr></table>
</fieldset></form>
<h2>Sign In</h2>
<%! form post %/user/sign-in %><fieldset>
<legend>Enter Username and Password</legend><% unless empty? target/errors [ %>
<ul><% foreach [key err] target/errors [ %>
<li><%= err/1 %></li><% ] %>
</ul><% ] %>
<table><tr>
<th><label for="user.id">Name:</label></th>
<td><%! field user/id (target/get 'id) %></td>
</tr><tr>
<th><label for="user.password">Pass:</label></th>
<td><%! password user/password %></td>
</tr><tr>
<td></td>
<td><%! submit do "Sign In" %>
</tr></table>
</fieldset></form>
<table>
<thead><tr>
<th>Name</th>
<th>Email</th><% foreach [role desc] users/locals/roles [ %>
<td><%= uppercase/part form role 1 %></td><% ] %>
</tr></thead>
<tbody><% foreach usr page/records [ %><tr>
<td><%! a user/profile/(usr/id) %><%= usr/id %></a></td>
<td><%= usr/get 'email %></td><% foreach [role desc] users/locals/roles [ %>
<td><% if usr/has-role? role [prin "X"] %></td><% ] %>
</tr><% ] %></tbody>
<tfoot><tr>
<td colspan="4"><%
either page/previous [
%><%! a user/list/(page/previous) %>Previous</a><%
][
%><i>Previous</i><%
]
%> | <%
either page/next [
%><%! a user/list/(page/next) %>Next</a><%
][
%><i>Next</i><%
]
%></td>
</tr></tfoot>
</table>
<h2>Profile: <%= target/id %></h2>
<%! form post user/update/(target/id) %><fieldset>
<legend>Edit Details</legend><% unless empty? user/errors [ %>
<ul><% foreach [key err] target/errors [ %>
<li><b><%= uppercase/part form key 1 %>:</b> <%= err/1 %></li><% ] %>
</ul><% ] %>
<table><%=
render/partial either any [is-owner is-target][%edit-profile.rsp][%show-profile.rsp]
%><%=
render/partial either all [not is-target is-moderator][%edit-roles.rsp][%show-roles.rsp]
%><tr>
<td></td>
<td><%! submit do "Update" %></td>
</tr></table>
</fieldset></form>
<tr>
<th></th>
<td><em><%= target/id %></em> (<%= target/get 'email %>)</td>
</tr>
<tr>
<th><label for="target.email">Email</label></th>
<td><%! field target/email (target/get 'email) %></td>
</tr><tr>
<th><label for="target.password">Password</label></th>
<td><%! password target/password %></td>
</tr><tr>
<th><label for="target.confirmation">Confirmation</label></th>
<td><%! password target/confirmation %></td>
</tr>
<% foreach [role desc] users/locals/roles [ %><tr>
<td></td>
<td><% either target/has-role? role [ %>Can<% ][ %>Can't <% ] %> <%= desc %></td>
</tr><% ] %>
<% foreach [role desc] users/locals/roles [ %><tr>
<td></td>
<td><%! label (join #role- role) %><%!
check (join #role- role) target/roles/(role) "yes" (target/has-role? role)
%> Can <%= desc %>?</label></td>
</tr><% ] %>