[Gd-chatter] r11330 - trunk/libraries/network/web-framework
turbo24prg at gwydiondylan.org
turbo24prg at gwydiondylan.org
Sun May 6 01:55:04 CEST 2007
Author: turbo24prg
Date: Sun May 6 01:55:00 2007
New Revision: 11330
Added:
trunk/libraries/network/web-framework/dsp.dylan (contents, props changed)
trunk/libraries/network/web-framework/permission.dylan (contents, props changed)
trunk/libraries/network/web-framework/utils.dylan (contents, props changed)
Modified:
trunk/libraries/network/web-framework/change.dylan
trunk/libraries/network/web-framework/changes.dylan (contents, props changed)
trunk/libraries/network/web-framework/class-browser.dylan (props changed)
trunk/libraries/network/web-framework/class-editor.dylan (props changed)
trunk/libraries/network/web-framework/command.dylan (props changed)
trunk/libraries/network/web-framework/library.dylan
trunk/libraries/network/web-framework/object-table.dylan (props changed)
trunk/libraries/network/web-framework/storage.dylan (contents, props changed)
trunk/libraries/network/web-framework/users.dylan
trunk/libraries/network/web-framework/web-framework.lid
trunk/libraries/network/web-framework/web-macro.dylan (props changed)
Log:
Job: minor
out-sourced some more usefull stuff, needs cleanup
Modified: trunk/libraries/network/web-framework/change.dylan
==============================================================================
--- trunk/libraries/network/web-framework/change.dylan (original)
+++ trunk/libraries/network/web-framework/change.dylan Sun May 6 01:55:00 2007
@@ -10,8 +10,8 @@
define method initialize (change :: <change>, #rest rest, #key, #all-keys)
next-method();
change.date := current-date();
- change.author := if (current-user())
- current-user().username;
+ change.author := if (authenticated-user())
+ authenticated-user().username;
else
"foo"
end;
Modified: trunk/libraries/network/web-framework/changes.dylan
==============================================================================
--- trunk/libraries/network/web-framework/changes.dylan (original)
+++ trunk/libraries/network/web-framework/changes.dylan Sun May 6 01:55:00 2007
@@ -64,8 +64,7 @@
init-keyword: title:;
slot updated :: false-or(<date>) = #f,
init-keyword: updated:;
- slot comments :: <table> = make(<table>),
- init-keyword: comments:;
+ slot comments :: <table> = make(<table>);
slot %comments-count :: <integer> = 0;
/* repeated slot extensionElement */
end;
@@ -76,6 +75,15 @@
entry.%comments-count;
end;
+define method initialize (entry :: <entry>, #key comments)
+ next-method();
+ if (comments)
+ for (comment in comments)
+ entry.comments[entry.comments-count] := comment;
+ end for;
+ end if;
+end;
+
define open class <comment> (<object>)
slot name :: <string>,
required-init-keyword: name:;
Added: trunk/libraries/network/web-framework/dsp.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/web-framework/dsp.dylan Sun May 6 01:55:00 2007
@@ -0,0 +1,122 @@
+module: web-framework
+
+define taglib web-framework () end;
+
+// errors
+define thread variable *errors* = #();
+
+// current action
+define thread variable *action* = #f;
+
+// sent values
+define thread variable *form* = #f;
+
+
+define tag show-login-url in web-framework
+ (page :: <dylan-server-page>, response :: <response>)
+ ()
+ format(output-stream(response),
+ "/?login&redirect=%s", current-url(escaped?: #t));
+end;
+
+define tag show-logout-url in web-framework
+ (page :: <dylan-server-page>, response :: <response>)
+ ()
+ format(output-stream(response),
+ "/?logout&redirect=%s", current-url(escaped?: #t));
+end;
+
+define named-method authenticated? in web-framework
+ (page :: <dylan-server-page>, request :: <request>)
+ authenticated-user()
+end;
+
+// action-test macros
+
+define macro action-tests-definer
+ { define action-tests () in ?taglib:name end }
+ => { }
+
+ { define action-tests ( ?:name , ?more:* ) in ?taglib:name end }
+ => {
+ define action-test ( ?name ) in ?taglib end;
+ define action-tests ( ?more ) in ?taglib end
+ }
+
+ { define action-tests ( ?:name ) in ?taglib:name end }
+ => { define action-test ( ?name ) in ?taglib end }
+end;
+
+define macro action-test-definer
+ { define action-test ( ?:name ) in ?taglib:name end }
+ => {
+ define named-method ?name ## "?" in ?taglib
+ (page :: <dylan-server-page>, request :: <request>)
+ *action* = ?#"name"
+ end;
+
+ define named-method ?name ## "-permitted?" in ?taglib
+ (page :: <dylan-server-page>, request :: <request>)
+ block ()
+ permitted?(?#"name");
+ #t;
+ exception (condition :: type-union(<authentication-error>, <permission-error>))
+ #f;
+ end;
+ end
+ }
+end;
+
+// object-test macros
+
+define macro object-tests-definer
+ { define object-tests () in ?taglib:name end }
+ => { }
+
+ { define object-tests ( ?:name , ?more:* ) in ?taglib:name end }
+ => {
+ define object-test ( ?name ) in ?taglib end;
+ define object-tests ( ?more ) in ?taglib end
+ }
+
+ { define object-tests ( ?:name ) in ?taglib:name end }
+ => { define object-test ( ?name ) in ?taglib end }
+end;
+
+define macro object-test-definer
+ { define object-test ( ?:name ) in ?taglib:name end }
+ => {
+ define thread variable "*" ## ?name ## "*" = #f;
+
+ define named-method ?name ## "?" in ?taglib
+ (page :: <dylan-server-page>, request :: <request>)
+ "*" ## ?name ## "*"
+ end
+ }
+end;
+
+// error-test macros
+
+define macro error-tests-definer
+ { define error-tests () in ?taglib:name end }
+ => { }
+
+ { define error-tests ( ?:name , ?more:* ) in ?taglib:name end }
+ => {
+ define error-test ( ?name ) in ?taglib end;
+ define error-tests ( ?more ) in ?taglib end
+ }
+
+ { define error-tests ( ?:name ) in ?taglib:name end }
+ => { define error-test ( ?name ) in ?taglib end }
+end;
+
+define macro error-test-definer
+ { define error-test (?:name) in ?taglib:name end }
+ => {
+ define named-method ?name ## "-error?" in ?taglib
+ (page :: <dylan-server-page>, request :: <request>)
+ member?(?#"name", *errors*)
+ end
+ }
+end;
Modified: trunk/libraries/network/web-framework/library.dylan
==============================================================================
--- trunk/libraries/network/web-framework/library.dylan (original)
+++ trunk/libraries/network/web-framework/library.dylan Sun May 6 01:55:00 2007
@@ -9,13 +9,15 @@
use xml-parser;
use system, import: { file-system, date, locators };
use dood;
+ use regular-expressions;
export object-table,
web-framework,
storage,
users,
changes,
- change;
+ change,
+ permission;
end;
define module object-table
@@ -32,7 +34,6 @@
use dood;
use file-system;
use threads;
- use format-out;
use koala;
use locators;
@@ -105,14 +106,13 @@
password-setter,
email,
email-setter,
- access,
- access-setter,
- access-level,
- access-level-setter,
- current-user,
- set-current-user,
+ additional-information,
+ additional-information-setter,
+ authenticated-user,
+ find-user,
+ authenticate,
login,
- logged-in?,
+ logout,
valid-user?;
end;
@@ -230,31 +230,39 @@
href, href-setter;
end;
+define module permission
+ use common-dylan;
+
+ export <permission-error>,
+ <authentication-error>;
+ export permitted?;
+end;
define module web-framework
use common-dylan;
use object-table;
use simple-xml;
- use format-out;
use koala;
-
+ use dsp;
+ use format;
+ use regular-expressions;
+
use web-framework-macro, export: all;
use storage;
use change;
+ use users;
+ use permission;
- export respond-to-get,
- respond-to-post;
+ export *errors*,
+ *action*,
+ *form*;
+
+ export action-test-definer,
+ action-tests-definer,
+ object-test-definer,
+ object-tests-definer,
+ error-test-definer,
+ error-tests-definer;
- export edit-form,
- remove-form,
- add-form,
- list-forms;
-
- export browse-list,
- browse-table,
- remove-form,
- browse,
- to-table-header,
- to-table;
+ export printable;
end;
-
Added: trunk/libraries/network/web-framework/permission.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/web-framework/permission.dylan Sun May 6 01:55:00 2007
@@ -0,0 +1,29 @@
+module: permission
+author: turbo24prg
+
+/*
+define macro with-permission
+ { with-permission(?action:*)
+ ?:body
+ end }
+ =>
+ { block ()
+ permitted?(?action);
+ ?body
+ exception (condition :: <permission-error>)
+ get(*unprivileged-page*);
+ exception (condition :: <authentication-error>)
+ get(*not-logged-in-page*);
+ end block }
+end;
+*/
+define class <permission-error> (<error>) end;
+define class <authentication-error> (<error>) end;
+
+define generic permitted? (action :: <symbol>, #key #all-keys)
+ => (permitted? :: <boolean>);
+
+define method permitted? (action :: <symbol>, #key)
+ => (permitted? :: <boolean>);
+ #t;
+end;
Modified: trunk/libraries/network/web-framework/storage.dylan
==============================================================================
--- trunk/libraries/network/web-framework/storage.dylan (original)
+++ trunk/libraries/network/web-framework/storage.dylan Sun May 6 01:55:00 2007
@@ -46,7 +46,6 @@
define method setup (class)
=> ();
- format-out(">>> no setup for: %=\n", class);
end;
define macro with-storage
@@ -118,7 +117,6 @@
end;
define method restore (directory :: <string>, filename :: <string>) => ()
- format-out("restoring %s/%s\n", directory, filename);
let dood = make(<dood>,
locator: merge-locators(as(<file-locator>, filename),
as(<directory-locator>, directory)),
Modified: trunk/libraries/network/web-framework/users.dylan
==============================================================================
--- trunk/libraries/network/web-framework/users.dylan (original)
+++ trunk/libraries/network/web-framework/users.dylan Sun May 6 01:55:00 2007
@@ -1,25 +1,43 @@
module: users
author: Hannes Mehnert <hannes at mehnert.org>
-define class <access-level> (<object>)
+define thread variable *authenticated-user* = #f;
+define variable *ignore-authorizations* = list();
+define variable *ignore-logins* = list();
+
+define open class <user> (<object>)
+ slot username :: <string>,
+ required-init-keyword: username:;
+ slot password :: <string>,
+ required-init-keyword: password:;
+ slot email :: <string>,
+ required-init-keyword: email:;
+ slot additional-information :: <table> = make(<table>),
+ init-keyword: additional-information:;
end;
-define open web-class <user> (<object>)
- data username :: <string>;
- data password :: <string>;
- data email :: <string>;
- slot access :: <list> = make(<list>);
- //slot access-level :: false-or(<access-level>) = #f;
-end;
-
-
define method initialize (user :: <user>, #rest rest, #key, #all-keys)
next-method();
- check(user);
- save(user);
+ let keyword = #f;
+ for (element in rest)
+ if (keyword)
+ unless (member?(keyword, #(#"username", #"password", #"email")))
+ user.additional-information[keyword] := element;
+ end;
+ keyword := #f;
+ else
+ keyword := element;
+ end if;
+ end for;
+ if (find-user(user.username))
+ signal(make(<web-error>,
+ error: "User with same name already exists!"))
+ else
+ save(user);
+ end if;
end;
-define inline-only method key (user :: <user>)
- => (res :: <string>)
+define method key (user :: <user>)
+ => (res :: <string>);
user.username;
end;
@@ -29,54 +47,80 @@
define method as (class == <string>, user :: <user>)
=> (result :: <string>)
- concatenate(user.username, " ", user.email);
+ user.username;
end;
-define thread variable *user* = #f;
-
-define method current-user () => (user :: false-or(<user>))
- *user*
+define function authenticated-user ()
+ => (user :: false-or(<user>));
+ *authenticated-user*
end;
-define method set-current-user (user :: <user>) => (user :: <user>)
- *user* := user;
-end;
-define method check (user :: <user>, #key test-result = 0)
- => (res :: <boolean>)
- if (element(storage(<user>), user.username, default: #f))
- signal(make(<web-error>,
- error: "User with same name already exists!"))
- else
- #t;
- end if;
+define function find-user (name :: <string>)
+ => (user :: false-or(<user>))
+ element(storage(<user>), name, default: #f);
end method check;
-define method valid-user? (username :: <string>, pass :: <string>)
- let user = element(storage(<user>), username, default: #f);
- if (user & (user.password = pass))
- #t;
+define method login ()
+ let redirect-url = get-query-value("redirect");
+ let authorization = header-value(#"authorization");
+ let user = check-authorization();
+ if (~authorization | ~user)
+ require-authorization();
+ elseif (user &
+ member?(user, *ignore-authorizations*, test: \=) &
+ member?(user, *ignore-logins*, test: \=))
+ *ignore-authorizations* :=
+ remove!(*ignore-authorizations*, user);
+ require-authorization();
+ elseif (user &
+ ~member?(user, *ignore-authorizations*, test: \=) &
+ member?(user, *ignore-logins*, test: \=))
+ *ignore-logins* :=
+ remove!(*ignore-logins*, user);
+ redirect-url & redirect-to(redirect-url);
else
- #f;
+ redirect-url & redirect-to(redirect-url);
+ end if;
+end;
+
+define function logout ()
+ let user = check-authorization();
+ if (user)
+ *ignore-authorizations* :=
+ add!(*ignore-authorizations*, user);
+ *ignore-logins* :=
+ add!(*ignore-logins*, user);
end if;
-end method valid-user?;
+ let redirect-url = get-query-value("redirect");
+ redirect-url & redirect-to(redirect-url);
+end;
-define method login (request :: <request>, username, password)
- => (username :: false-or(<string>))
- if (username & password & valid-user?(username, password))
- let session = ensure-session(request);
- *user* := storage(<user>)[username];
- set-attribute(session, #"username", username);
- username;
+define function check-authorization ()
+ => (user :: false-or(<user>));
+ let authorization = header-value(#"authorization");
+ if (authorization)
+ let user = find-user(head(authorization));
+ if (user & user.password = tail(authorization))
+ user;
+ end if;
end if;
-end method login;
+end;
-define method logged-in? (request :: <request>)
- => (username :: false-or(<string>))
- let session = get-session(request);
- if (session)
- let username = get-attribute(session, #"username");
- *user* := storage(<user>)[username];
- username;
- end;
-end method logged-in?;
+define function authenticate ()
+ => (user :: false-or(<user>));
+ let authorization = header-value(#"authorization");
+ if (authorization)
+ let user = find-user(head(authorization));
+ *authenticated-user* := if (user & user.password = tail(authorization) &
+ ~member?(user, *ignore-authorizations*, test: \=) &
+ ~member?(user, *ignore-logins*, test: \=)) //???
+ user;
+ end if;
+ end if;
+end;
+define function require-authorization (#key realm :: <string> = "koala")
+ let headers = current-response().response-headers;
+ add-header(headers, "WWW-Authenticate", concatenate("Basic realm=\"", realm, "\""));
+ unauthorized-error(headers: headers);
+end;
Added: trunk/libraries/network/web-framework/utils.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/web-framework/utils.dylan Sun May 6 01:55:00 2007
@@ -0,0 +1,5 @@
+module: web-framework
+
+define function printable (title :: <string>)
+ regexp-replace(title, "/", "");
+end;
Modified: trunk/libraries/network/web-framework/web-framework.lid
==============================================================================
--- trunk/libraries/network/web-framework/web-framework.lid (original)
+++ trunk/libraries/network/web-framework/web-framework.lid Sun May 6 01:55:00 2007
@@ -2,10 +2,11 @@
files: library
object-table
storage
- class-browser
- class-editor
web-macro
command
change
changes
users
+ dsp
+ permission
+ utils
More information about the chatter
mailing list