Index: openacs-4/packages/acs-authentication/acs-authentication.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/acs-authentication.info,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-authentication/acs-authentication.info 22 Aug 2003 10:55:00 -0000 1.1
@@ -0,0 +1,28 @@
+
+
+
+
+ OpenACS Authentication
+ OpenACS Authentication
+ t
+ t
+
+
+ Lars Pind
+ Authentication and related functionality.
+ Collaboraid
+ Implements authentication-related security functions for OpenACS, including authentication, password maangement, account management, session management, etc.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: openacs-4/packages/acs-authentication/tcl/apm-callback-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/apm-callback-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-authentication/tcl/apm-callback-procs.tcl 22 Aug 2003 10:55:00 -0000 1.1
@@ -0,0 +1,297 @@
+ad_library {
+ Installation procs for authentication, account management, and password management,
+
+ @author Lars Pind (lars@collaobraid.biz)
+ @creation-date 2003-05-13
+ @cvs-id $Id: apm-callback-procs.tcl,v 1.1 2003/08/22 10:55:00 simonc Exp $
+}
+
+namespace eval auth {}
+namespace eval auth::authentication {}
+namespace eval auth::password {}
+namespace eval auth::registration {}
+
+
+ad_proc -private auth::package_install {} {} {
+
+ db_transaction {
+ # Create service contracts
+ auth::authentication::create_contract
+ auth::password::create_contract
+ auth::registration::create_contract
+
+ # Register local authentication implementations and update the local authority
+ auth::local::install
+ }
+}
+
+ad_proc -private auth::package_uninstall {} {} {
+
+ db_transaction {
+
+ # Unregister local authentication implementations and update the local authority
+ auth::local::uninstall
+
+ # Delete service contracts
+ auth::authentication::delete_contract
+ auth::password::delete_contract
+ auth::registration::delete_contract
+ }
+}
+
+
+#####
+#
+# auth_authentication service contract
+#
+#####
+
+ad_proc -private auth::authentication::create_contract {} {
+ Create service contract for authentication.
+} {
+ set spec {
+ name "auth_authentication"
+ description "Service contract to handle authentication"
+ operations {
+ Authenticate {
+ description {
+ Validate this username/password combination, and return the result.
+ Valid auth_status codes are 'ok', 'no_account', 'bad_password', 'auth_error', 'failed_to_connect'.
+ The last, 'failed_to_connect', is reserved for communications or implementation errors.
+ Valid account_status codes are 'ok' and 'closed'.
+ }
+ input {
+ username:string
+ password:string
+ parameters:string,multiple
+ }
+ output {
+ auth_status:string
+ auth_message:string
+ account_status:string
+ account_message:string
+ }
+ }
+ GetParameters {
+ description {
+ Get an arraay-list of the parameters required by this service contract implementation.
+ }
+ output {
+ parameters:string,multiple
+ }
+ }
+ }
+ }
+
+ acs_sc::contract::new_from_spec -spec $spec
+
+ # LARS:
+ # If we do the configurator package, this proc should register the parameters as well,
+ # and GetParameters should return parameter_set_id.
+ # Hm. But it'll be up to the specific implementation which parameters it takes ... yeah, above won't work.
+}
+
+ad_proc -private auth::authentication::delete_contract {} {
+ Delet service contract for authentication.
+} {
+ acs_sc::contract::delete -name "auth_authentication"
+}
+
+#####
+#
+# auth_password service contract
+#
+#####
+
+ad_proc -private auth::password::create_contract {} {
+ Create service contract for password management.
+} {
+ set spec {
+ name "auth_password"
+ description "Service contract for password management."
+ operations {
+ CanChangePassword {
+ description {
+ Return whether the user can change his/her password through this implementation.
+ The value is not supposed to depend on the username and should be cachable.
+ }
+ input {
+ parameters:string,multiple
+ }
+ output {
+ changeable_p:boolean
+ }
+ iscachable_p "t"
+ }
+ ChangePassword {
+ description {
+ Change the user's password.
+ }
+ input {
+ username:string
+ old_password:string
+ new_password:string
+ parameters:string,multiple
+ }
+ output {
+ successful_p:boolean
+ message:string
+ }
+ }
+ CanRetrievePassword {
+ description {
+ Return whether the user can retrieve his/her password through this implementation.
+ The value is not supposed to depend on the username and should be cachable.
+ }
+ input {
+ parameters:string,multiple
+ }
+ output {
+ retrievable_p:boolean
+ }
+ iscachable_p "t"
+ }
+ RetrievePassword {
+ description {
+ Retrieve the user's password. The implementation can either return the password, in which case
+ the authentication API will email the password to the user. Or it can email the password
+ itself, in which case it would return the empty string for password.
+ }
+ input {
+ username:string
+ parameters:string,multiple
+ }
+ output {
+ successful_p:boolean
+ message:string
+ password:string
+ }
+ }
+ CanResetPassword {
+ description {
+ Return whether the user can reset his/her password through this implementation.
+ The value is not supposed to depend on the username and should be cachable.
+ }
+ input {
+ parameters:string,multiple
+ }
+ output {
+ retrievable_p:boolean
+ }
+ iscachable_p "t"
+ }
+ ResetPassword {
+ description {
+ Reset the user's password to a new, randomly generated value.
+ The implementation can either return the password, in which case
+ the authentication API will email the password to the user. Or it can email the password
+ itself, in which case it would return the empty string.
+ }
+ input {
+ username:string
+ parameters:string,multiple
+ }
+ output {
+ successful_p:boolean
+ message:string
+ password:string
+ }
+ }
+ GetParameters {
+ description {
+ Get an arraay-list of the parameters required by this service contract implementation.
+ }
+ output {
+ parameters:string,multiple
+ }
+ }
+ }
+ }
+
+ acs_sc::contract::new_from_spec -spec $spec
+}
+
+ad_proc -private auth::password::delete_contract {} {
+ Delete service contract for password management.
+} {
+ acs_sc::contract::delete -name "auth_password"
+}
+
+
+#####
+#
+# auth_registration service contract
+#
+#####
+
+ad_proc -private auth::registration::create_contract {} {
+ Create service contract for account registration.
+} {
+ set spec {
+ name "auth_registration"
+ description "Service contract to handle account registration"
+ operations {
+ GetElements {
+ description {
+ Get a list of required and a list of optional fields available when registering accounts through this
+ service contract implementation.
+ }
+ input {
+ parameters:string,multiple
+ }
+ output {
+ requiered:string,multiple
+ optional:string,multiple
+ }
+ }
+ Register {
+ description {
+ Register a new account. Valid status codes are: 'ok', 'data_error', and 'reg_error', and 'fail'.
+ 'data_error' means that the implementation is returning an array-list of element-name, message
+ with error messages for each individual element. 'reg_error' is any other registration error,
+ and 'fail' is reserved to communications or implementation errors.
+ }
+ input {
+ parameters:string,multiple
+ username:string
+ authority_id:integer
+ first_names:string
+ last_name:string
+ email:string
+ url:string
+ password:string
+ secret_question:string
+ secret_answer:string
+ }
+ output {
+ creation_status:string
+ creation_message:string
+ element_messages:string,multiple
+ account_status:string
+ account_message:string
+ }
+ }
+ GetParameters {
+ description {
+ Get an array-list of the parameters required by this service contract implementation.
+ }
+ output {
+ parameters:string,multiple
+ }
+ }
+ }
+ }
+
+ acs_sc::contract::new_from_spec -spec $spec
+
+ # LARS:
+ # If we do the configurator package, this proc should register the parameters as well,
+ # and GetParameters should return parameter_set_id.
+}
+
+
+ad_proc -private auth::registration::delete_contract {} {
+ Delete service contract for account registration.
+} {
+ acs_sc::contract::delete -name "auth_registration"
+}
Index: openacs-4/packages/acs-authentication/tcl/authentication-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/authentication-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-authentication/tcl/authentication-procs.tcl 22 Aug 2003 10:55:00 -0000 1.1
@@ -0,0 +1,327 @@
+ad_library {
+ Tcl API for authentication, account management, and password management,
+
+ @author Lars Pind (lars@collaobraid.biz)
+ @creation-date 2003-05-13
+ @cvs-id $Id: authentication-procs.tcl,v 1.1 2003/08/22 10:55:00 simonc Exp $
+}
+
+namespace eval auth {}
+namespace eval auth::authentication {}
+namespace eval auth::password {}
+namespace eval auth::registration {}
+
+
+
+#####
+#
+# auth namespace public procs
+#
+#####
+
+ad_proc -public auth::require_login {} {
+ If the current session is not authenticated, redirect to the
+ login page, and aborts the current page script.
+ Otherwise, returns the user_id of the user logged in.
+ Use this in a page script to ensure that only registered and authenticated
+ users can execute the page, for example for posting to a forum.
+
+ @return user_id of user, if the user is logged in. Otherwise will issue an ad_script_abort.
+
+ @see ad_script_abort
+} {
+ return [ad_maybe_redirect_for_registration]
+}
+
+ad_proc -public auth::authenticate {
+ {-authority_id ""}
+ {-username:required}
+ {-password:required}
+} {
+ Try to authenticate login the user by validating the username/password combination,
+ and return authentication and account status codes.
+
+ @param username Username of the user.
+
+ @param passowrd The password as the user entered it.
+
+ @param authority_id The ID of the authority to ask to verify the user. Leave blank for local authority.
+} {
+ array set auth_info [auth::authentication::Authenticate \
+ -username $username \
+ -authority_id $authority_id \
+ -password $password]
+
+ # Returns:
+ # auth_info(auth_status)
+ # auth_info(auth_message)
+ # auth_info(account_status)
+ # auth_info(account_message)
+
+ if { [string equal $auth_info(auth_status) "ok"] && [string equal $auth_info(account_status) "ok"] } {
+
+ # LARS:
+ # Note: This has changed in the design to not throw away remote account status
+
+ # WRONG! External account status was ok, so we don't need that info anymore
+ # We'll replace it with local account status below
+ array unset auth_info account_status
+ array unset auth_info account_message
+
+ # Map to row in local users table
+ array set auth_info [auth::get_local_account \
+ -username $username \
+ -authority_id $authority_id]
+
+ # Returns:
+ # auth_info(account_status)
+ # auth_info(account_message)
+ # auth_info(user_id)
+ # These are appended to the existing entries in auth_info
+
+ if { [string equal $auth_info(account_status) "ok"] } {
+ auth::issue_login -user_id $auth_info(user_id)
+ }
+ }
+
+ return [array get auth_info]
+}
+
+ad_proc -private auth::issue_login {
+ {-user_id:required}
+ {-persistent:boolean}
+} {
+ Issue the login cookie.
+} {
+ ad_user_login -forever=$persistent_p $user_id
+}
+
+ad_proc -public auth::register_user {
+ {-authority_id ""}
+ {-username:required}
+ {-password:required}
+ {-first_names ""}
+ {-last_name ""}
+ {-email ""}
+ {-url ""}
+ {-secret_question ""}
+ {-secret_answer ""}
+} {
+
+ @param authority_id The id of the authority to create the user in. Defaults to
+ the authority with lowest sort_order that has register_p set to true.
+} {
+ set authorities_list [list]
+
+ # Always register the user locally
+ lappend authorities_list [auth::authority::local]
+
+ # Default authority_id if none was provided
+ if { [empty_string_p $authority_id] } {
+ # Pick the first authority that can create users
+ set authority_id [db_string first_registering_authority {
+ select authority_id
+ from auth_authorities
+ where register_p = 't'
+ and sort_order = (select max(sort_order)
+ from auth_authorities
+ where register_p = 't'
+ )
+ } -default ""]
+
+ if { [empty_string_p $authority_id] } {
+ error "No authority_id provided and could not find an authority that can create users"
+ }
+
+ lappend authorities_list $authority_id
+ }
+
+ # Register the user both with the local authority and the external one
+ db_transaction {
+ foreach authority_id $authorities_list {
+ auth::registration::Register \
+ -authority_id $authority_id \
+ -username $user_name \
+ -password $password \
+ -first_names $first_names \
+ -last_name $last_name \
+ -email $email \
+ -url $url \
+ -secret_question $secret_question \
+ -secret_answer $secret_answer
+ }
+ }
+}
+
+
+
+#####
+#
+# auth namespace private procs
+#
+#####
+
+ad_proc -private auth::get_local_account {
+ {-username:required}
+ {-authority_id ""}
+} {
+ Get the user_id of the local account for the given
+ username and domain combination.
+
+ @param username The username to find
+
+ @param authority_id The ID of the authority to ask to verify the user. Leave blank for local authority.
+} {
+ array set auth_info [list]
+
+ # Will return:
+ # auth_info(account_status)
+ # auth_info(account_message)
+ # auth_info(user_id)
+
+ if { [empty_string_p $authority_id] } {
+ set authority_id [auth::authority::local]
+ }
+
+ set account_found_p [db_0or1row select_user_info {
+ select user_id,
+ email,
+ member_state,
+ email_verified_p
+ from cc_users
+ where username = :username
+ and authority_id = :authority_id
+ }]
+
+ if { !$account_found_p } {
+ # Local user account doesn't exist
+ set auth_info(account_status) "no_account"
+ set auth_info(account_message) {}
+ return [array get auth_info]
+ }
+
+ # Check local account status
+
+ # Initialize to 'closed', because most cases below mean the account is closed
+ set auth_info(account_status) "closed"
+
+ switch $member_state {
+ "approved" {
+ if { $email_verified_p == "f" } {
+ set row_id [db_string rowid_for_email {
+ select rowid from users where user_id = :user_id
+ }]
+
+ # Send email verification email to user
+ set confirmation_url "[ad_url]/register/email-confirm?[export_vars { row_id }]"
+ with_catch errmsg {
+ ns_sendmail \
+ $email \
+ $notification_address \
+ "[_ acs-subsite.lt_Welcome_to_system_nam]" \
+ "[_ acs-subsite.lt_To_confirm_your_regis]"
+ }
+
+ set auth_info(account_message) "
[_ acs-subsite.lt_Registration_informat]
[_ acs-subsite.lt_Please_read_and_follo]
"
+ } else {
+ set auth_info(account_status) "ok"
+ }
+ }
+ "banned" {
+ set auth_info(account_message) [_ acs-subsite.lt_Sorry_but_it_seems_th]
+ }
+ "deleted" {
+ set auth_info(account_message) "[_ acs-subsite.Welcome_Back_1] [_ acs-subsite.to_site_link_1]."
+ }
+ "rejected" - "needs_approval" {
+ set auth_info(account_message) "[_ acs-subsite.lt_registration_request_submitted]
[_ acs-subsite.Thank_you]
"
+ }
+ default {
+ set auth_info(account_message) "There was a problem authenticating the account: $user_id. Most likely, the database contains users with no user_state."
+ ns_log Warning "Problem with registration state machine on user-login.tcl"
+ }
+ }
+ set auth_info(user_id) $user_id
+
+ return [array get auth_info]
+}
+
+
+
+#####
+#
+# auth::authentication
+#
+#####
+
+ad_proc -private auth::authentication::Authenticate {
+ {-authority_id ""}
+ {-username:required}
+ {-password:required}
+} {
+ Invoke the Authenticate service contract operation for the given authority.
+
+ @param authority_id The ID of the authority to ask to verify the user. Defaults to local authority.
+ @param username Username of the user.
+ @param passowrd The password as the user entered it.
+} {
+ if { [empty_string_p $authority_id] } {
+ set authority_id [auth::authority::local]
+ }
+
+ # TODO:
+ # Implement parameters
+
+ return [acs_sc::invoke \
+ -contract "auth_authentication" \
+ -impl [auth::authority::get_element -authority_id $authority_id -element "auth_impl_name"] \
+ -operation Authenticate \
+ -call_args [list $username $password [list]]]
+}
+
+#####
+#
+# auth::registration
+#
+#####
+
+ad_proc -private auth::registration::Register {
+ {-authority_id:required}
+ {-username:required}
+ {-password:required}
+ {-first_names ""}
+ {-last_name ""}
+ {-email ""}
+ {-url ""}
+ {-secret_question ""}
+ {-secret_answer ""}
+} {
+ Invoke the Register service contract operation for the given authority.
+
+ @authority_id Id of the authority. Defaults to local authority.
+ @url Any URL (homepage) associated with the new user
+ @secret_question Question to ask on forgotten password
+ @secret_answer Answer to forgotten password question
+} {
+ if { [empty_string_p $authority_id] } {
+ set authority_id [auth::authority::local]
+ }
+
+ # TODO:
+ # Implement parameters
+
+ return [acs_sc::invoke \
+ -contract "auth_registration" \
+ -impl [auth::authority::get_element -authority_id $authority_id -element "auth_impl_name"] \
+ -operation Register \
+ -call_args [list [list] \
+ $username \
+ $authority_id \
+ $first_names \
+ $last_name \
+ $email \
+ $url \
+ $password \
+ $secret_question \
+ $secret_answer]]
+}
Index: openacs-4/packages/acs-authentication/tcl/authority-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/authority-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-authentication/tcl/authority-procs.tcl 22 Aug 2003 10:55:00 -0000 1.1
@@ -0,0 +1,268 @@
+ad_library {
+ Procs for authority management.
+
+ @author Lars Pind (lars@collaobraid.biz)
+ @creation-date 2003-05-14
+ @cvs-id $Id: authority-procs.tcl,v 1.1 2003/08/22 10:55:00 simonc Exp $
+}
+
+namespace eval auth {}
+namespace eval auth::authority {}
+
+
+
+#####
+#
+# auth::authority
+#
+#####
+
+
+ad_proc -private auth::authority::get_columns {} {
+ Get a list of the columns in the auth_authorities table.
+
+ @author Lars Pind (lars@collaboraid.biz)
+} {
+ return {
+ authority_id
+ short_name
+ pretty_name
+ active_p
+ sort_order
+ auth_impl_id
+ auth_p
+ pwd_impl_id
+ forgotten_pwd_url
+ change_pwd_url
+ register_impl_id
+ register_p
+ register_url
+ }
+}
+
+
+ad_proc -private auth::authority::get_required_columns {} {
+ Get a list of the required columns in the auth_authorities table.
+
+ @author Lars Pind (lars@collaboraid.biz)
+} {
+ return {
+ authority_id
+ short_name
+ pretty_name
+ }
+}
+
+ad_proc -private auth::authority::get_select_columns {} {
+ Get a list of the columns which can be selected from auth_authorities table.
+
+ @author Lars Pind (lars@collaboraid.biz)
+} {
+ return [concat [get_columns] auth_impl_name pwd_impl_name register_impl_name]
+}
+
+
+ad_proc -public auth::authority::create {
+ {-authority_id ""}
+ {-array:required}
+} {
+ Create a new authentication authority.
+
+ @option authority_id Authority_id, or blank if you want one generated for you.
+
+ @param array Name of an array containing the column values. The entries are:
+
+
+
+ - short_name Short name for authority. Used as a key by applications to identify this authority.
+
+
- pretty_name Label for the authority to be shown in a list to users picking a authority.
+
+
- active_p 't' if this authority available, 'f' if it's disabled. Defaults to 't'.
+
+
- sort_order Sort ordering determines the order in which authoritys are listed in the user interface.
+ Defaults to 1.
+
+
- auth_impl_id The ID of the implementation of the 'auth_authentication' service contract.
+ Defaults to none.
+
+
- auth_p Say 't' to enable authentication in this authority, 'f' to disable. Defaults ot 't'.
+
+
- pwd_impl_id The ID of the implementation of the 'auth_password' service contract. Defaults to none.
+
+
- forgotten_pwd_url An alternative URL to redirect to when the user has forgotten his/her password.
+ Defaults to none.
+
+
- change_pwd_url An alternative URL to redirect to when the user wants to change his/her password.
+ Defaults to none.
+
+
- register_impl_id The ID of the implementation of the 'auth_register' service contract.
+ Defaults to none.
+
+
- register_p Say 't' to enable registration in this authority, 'f' to disable. Defaults to 't'.
+
+
- register_url An alternative URL to redirect to when the user wants to register for an account.
+ Defaults to none.
+
+
+ @author Lars Pind (lars@collaboraid.biz)
+} {
+ upvar $array row
+
+ db_transaction {
+
+ if { [empty_string_p authority_id] } {
+ set authority_id [db_nextval "auth_authority_id_seq"]
+ }
+
+ set names [array names row]
+
+ set columns [get_columns]
+
+ # Check that the columns provided in the array are all valid
+ # Set array entries as local variables
+ foreach name $names {
+ if { [lsearch -exact $columns $name] == -1 } {
+ error "Attribute '$name' isn't valid for auth_authorities."
+ }
+ set $name $row($name)
+ }
+
+ # Check that the required columns are there
+ foreach name [get_required_columns] {
+ if { ![info exists $name] } {
+ error "Required column '$name' missing for auth_authorities."
+ }
+ }
+
+ lappend names "autority_id"
+
+ db_dml insert_authority "
+ insert into auth_authorities (
+ [join $names ", "]
+ ) values (
+ :[join $names ", :"]
+ )
+ "
+ }
+
+ return $authority_id
+}
+
+
+ad_proc -public auth::authority::get {
+ {-authority_id:required}
+ {-array:required}
+} {
+ Get info about a authority by authority_id.
+
+ @param authority_id The authority you want to get.
+
+ @param array Name of an array into which you want the attributes delivered.
+
+ @return authority_id
+
+ @author Lars Pind (lars@collaboraid.biz)
+} {
+ upvar $array row
+
+ set columns [get_columns]
+
+ lappend columns "(select impl_name from acs_sc_impls where impl_id = auth_impl_id) as auth_impl_name"
+ lappend columns "(select impl_name from acs_sc_impls where impl_id = pwd_impl_id) as pwd_impl_name"
+ lappend columns "(select impl_name from acs_sc_impls where impl_id = register_impl_id) as register_impl_name"
+
+ db_1row select_authority "
+ select [join $columns ",\n "]
+ from auth_authorities
+ where authority_id = :authority_id
+ " -column_array row
+
+ return $authority_id
+}
+
+ad_proc -public auth::authority::get_element {
+ {-authority_id:required}
+ {-element:required}
+} {
+ Return a specific element of the auth_authority data table.
+} {
+ if { [lsearch [get_select_columns] $element] == -1 } {
+ error "Column '$element' not found in the auth_authority data source."
+ }
+
+ get -authority_id $authority_id -array row
+ return $row($element)
+}
+
+
+ad_proc -public auth::authority::get_id {
+ {-short_name:required}
+} {
+ Get authority_id by short_name.
+
+ @param short_name The short_name of the authority you wish to get information for.
+
+ @return authority_id or the empty string if short_name doesn't exist.
+
+ @author Lars Pind (lars@collaboraid.biz)
+} {
+ # TODO: Cache
+ return [db_string select_authority_id { select authority_id from auth_authorities where short_name = :short_name } -default {}]
+}
+
+ad_proc -public auth::authority::local {} {
+ Returns the authority_id of the local authority.
+} {
+ return [auth::authority::get_id -short_name "local"]
+}
+
+
+ad_proc -public auth::authority::edit {
+ {-authority_id:required}
+ {-array:required}
+} {
+ Edit info about a authority. Note, that there's no checking that the columns you name exist.
+
+ @param authority_id The authority you want to get.
+
+ @param array Name of an array with column values to update.
+
+ @author Lars Pind (lars@collaboraid.biz)
+} {
+ upvar $array row
+
+ set names [array names row]
+
+ # Construct clauses for the update statement
+ set set_clauses [list]
+ foreach name $names {
+ lappend set_clauses "$name = :$name"
+ }
+
+ if { [llength $set_clauses] == 0 } {
+ # No rows to update
+ return
+ }
+
+ set columns [get_columns]
+
+ # Check that the columns provided in the array are all valid
+ # Set array entries as local variables
+ foreach name $names {
+ if { [lsearch -exact $columns $name] == -1 } {
+ error "Attribute '$name' isn't valid for auth_authorities."
+ }
+ if { [string equal $name "authority_id"] } {
+ error "Attribute '$name' is the primary key for auth_authorities, and thus cannot be edited."
+ }
+ set $name $row($name)
+ }
+
+ db_dml update_authority "
+ update auth_authorities
+ set [join $set_clauses ", "]
+ where authority_id = :authority_id
+ "
+}
+
Index: openacs-4/packages/acs-authentication/tcl/local-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/local-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-authentication/tcl/local-procs.tcl 22 Aug 2003 10:55:00 -0000 1.1
@@ -0,0 +1,464 @@
+ad_library {
+ Procs for local authentication.
+
+ @author Lars Pind (lars@collaobraid.biz)
+ @creation-date 2003-05-13
+ @cvs-id $Id: local-procs.tcl,v 1.1 2003/08/22 10:55:00 simonc Exp $
+}
+
+namespace eval auth {}
+namespace eval auth::local {}
+namespace eval auth::local::authentication {}
+namespace eval auth::local::password {}
+namespace eval auth::local::registration {}
+
+
+
+#####
+#
+# auth::local
+#
+#####
+
+ad_proc -private auth::local::install {} {
+ Register local service contract implementations,
+ and update the local authority with live information.
+} {
+ db_transaction {
+ # Register the local service contract implementations
+ set row(auth_impl_id) [auth::local::authentication::register_impl]
+ set row(pwd_impl_id) [auth::local::password::register_impl]
+ set row(register_impl_id) [auth::local::registration::register_impl]
+
+ # Set the authority pretty-name to be the system name
+ set row(pretty_name) [ad_system_name]
+
+ auth::authority::edit \
+ -authority_id [auth::authority::local] \
+ -array row
+ }
+}
+
+ad_proc -private auth::local::uninstall {} {
+ Unregister the local service contract implementation, and update the
+ local authority to reflect that.
+} {
+ db_transaction {
+ # Update the local authority to reflect the loss of the implementations
+ set row(auth_impl_id) {}
+ set row(pwd_impl_id) {}
+ set row(register_impl_id) {}
+
+ auth::authority::edit \
+ -authority_id [auth::authority::local] \
+ -array row
+
+ # Unregister the implementations
+ auth::local::authentication::unregister_impl
+ auth::local::password::unregister_impl
+ auth::local::registration::unregister_impl
+ }
+}
+
+
+
+
+#####
+#
+# auth::local::authentication
+#
+#####
+#
+# The 'auth_authentication' service contract implementation
+#
+
+ad_proc -private auth::local::authentication::register_impl {} {
+ Register the 'local' implementation of the 'auth_authentication' service contract.
+
+ @return impl_id of the newly created implementation.
+} {
+ set spec {
+ contract_name "auth_authentication"
+ owner "acs-authentication"
+ name "local"
+ aliases {
+ Authenticate auth::local::authentication::Authenticate
+ GetParameters auth::local::authentication::GetParameters
+ }
+ }
+
+ return [acs_sc::impl::new_from_spec -spec $spec]
+}
+
+ad_proc -private auth::local::authentication::unregister_impl {} {
+ Unregister the 'local' implementation of the 'auth_authentication' service contract.
+} {
+ acs_sc::impl::delete -contract_name "auth_authentication" -impl_name "local"
+}
+
+
+ad_proc -private auth::local::authentication::Authenticate {
+ username
+ password
+ {parameters {}}
+} {
+ Implements the GetParameters operation of the auth_authentication
+ service contract for the local account implementation.
+} {
+ array set auth_info [list]
+
+ # TODO: username = email parameter ...
+
+ set username [string tolower $username]
+
+ set authority_id [auth::authority::local]
+
+ set account_exists_p [db_0or1row select_user_info {
+ select user_id
+ from cc_users
+ where username = :username
+ and authority_id = :authority_id
+ }]
+
+ if { !$account_exists_p } {
+ set auth_info(auth_status) "no_account"
+ return [array get auth_info]
+ }
+
+ if { [ad_check_password $user_id $password] } {
+ set auth_info(auth_status) "ok"
+ } else {
+ set auth_info(auth_status) "bad_password"
+ return [array get auth_info]
+ }
+
+ # We set 'external' account status to 'ok', because the
+ # local account status will be checked anyways
+ set auth_info(account_status) ok
+
+ return [array get auth_info]
+}
+
+ad_proc -private auth::local::authentication::GetParameters {} {
+ Implements the GetParameters operation of the auth_authentication
+ service contract for the local account implementation.
+} {
+ # No parameters
+ return [list]
+}
+
+
+#####
+#
+# auth::local::password
+#
+#####
+#
+# The 'auth_password' service contract implementation
+#
+
+ad_proc -private auth::local::password::register_impl {} {
+ Register the 'local' implementation of the 'auth_password' service contract.
+
+ @return impl_id of the newly created implementation.
+} {
+ set spec {
+ contract_name "auth_password"
+ owner "acs-authentication"
+ name "local"
+ aliases {
+ CanChangePassword auth::local::password::CanChangePassword
+ ChangePassword auth::local::password::ChangePassword
+ CanRetrievePassword auth::local::password::CanRetrievePassword
+ RetrievePassword auth::local::password::RetrievePassword
+ CanResetPassword auth::local::password::CanResetPassword
+ ResetPassword auth::local::password::ResetPassword
+ }
+ }
+ return [acs_sc::impl::new_from_spec -spec $spec]
+}
+
+ad_proc -private auth::local::password::unregister_impl {} {
+ Unregister the 'local' implementation of the 'auth_password' service contract.
+} {
+ acs_sc::impl::delete -contract_name "auth_password" -impl_name "local"
+}
+
+
+ad_proc -private auth::local::password::CanChangePassword {} {
+ Implements the CanChangePassword operation of the auth_password
+ service contract for the local account implementation.
+} {
+ # Yeah, we can change your password
+ return 1
+}
+
+ad_proc -private auth::local::password::CanRetrievePassword {} {
+ Implements the CanRetrievePassword operation of the auth_password
+ service contract for the local account implementation.
+} {
+ # Nope, passwords are stored hashed, so we can't retrieve it for you
+ return 0
+}
+
+ad_proc -private auth::local::password::CanResetPassword {} {
+ Implements the CanResetPassword operation of the auth_password
+ service contract for the local account implementation.
+} {
+ # Yeah, we can reset for you.
+ return 1
+}
+
+ad_proc -private auth::local::password::ChangePassword {
+ username
+ old_password
+ new_password
+ {parameters {}}
+} {
+ Implements the ChangePassword operation of the auth_password
+ service contract for the local account implementation.
+} {
+ array set result {
+ successful_p 0
+ message {}
+ }
+
+ if { ![ad_check_password $user_id $old_password] } {
+ set result(message) "Old password is incorrect."
+ return [array get result]
+ }
+ if { [catch { ad_change_password $user_id $password_1 } errmsg] } {
+ ns_log Warning "Error changing local password: $errmsg"
+ set result(message) "We experienced an error changing your password."
+ return [array get result]
+ }
+
+ set result(successful_p) 1
+
+ return [array get result]
+}
+
+ad_proc -private auth::local::password::RetrievePassword {
+ username
+ parameters
+} {
+ Implements the RetrievePassword operation of the auth_password
+ service contract for the local account implementation.
+} {
+ set result(successful_p) 0
+ set result(message) "Cannot retrieve your password."
+
+ return [array get result]
+}
+
+ad_proc -private auth::local::password::ResetPassword {
+ username
+ parameters
+} {
+ Implements the ResetPassword operation of the auth_password
+ service contract for the local account implementation.
+} {
+ set result(successful_p) 0
+ set result(message) {}
+
+ # TODO:
+ # What about security question/answer? Who should ask for those?
+
+ # Change the password
+ set password [ad_generate_random_string]
+ ad_change_password $user_id $password
+
+ # We return the new passowrd here and let the OpenACS framework send the email with the new password
+ set result(password) $password
+
+ return [array get result]
+}
+
+
+
+#####
+#
+# auth::local::register
+#
+
+
+
+#####
+#
+# The 'auth_registration' service contract implementation
+#
+
+ad_proc -private auth::local::registration::register_impl {} {
+ Register the 'local' implementation of the 'auth_registration' service contract.
+
+ @return impl_id of the newly created implementation.
+} {
+ set spec {
+ contract_name "auth_registration"
+ owner "acs-authentication"
+ name "local"
+ aliases {
+ GetElements auth::local::registration::GetElements
+ Register auth::local::registration::Register
+ GetParameters auth::local::registration::GetParameters
+ }
+ }
+ return [acs_sc::impl::new_from_spec -spec $spec]
+}
+
+ad_proc -private auth::local::registration::unregister_impl {} {
+ Unregister the 'local' implementation of the 'auth_register' service contract.
+} {
+ acs_sc::impl::delete -contract_name "auth_registration" -impl_name "local"
+}
+
+ad_proc -private auth::local::registration::GetElements {
+ {parameters ""}
+} {
+ Implements the GetElements operation of the auth_register
+ service contract for the local account implementation.
+} {
+ set result(required) { username email first_names last_name }
+ set result(optional) { url }
+
+ if { ![parameter::get -parameter RegistrationProvidesRandomPasswordP -default 0] } {
+ lappend result(required) password
+ }
+
+ if { [parameter::get -parameter RequireQuestionForPasswordResetP -default 1] &&
+ [parameter::get -parameter UseCustomQuestionForPasswordReset -default 1] } {
+ lappend result(required) secret_question secret_answer
+ }
+
+ return [array get result]
+}
+
+ad_proc -private auth::local::registration::Register {
+ parameters
+ username
+ authority_id
+ first_names
+ last_name
+ email
+ url
+ password
+ secret_question
+ secret_answer
+} {
+ Implements the Register operation of the auth_register
+ service contract for the local account implementation.
+} {
+ array set result {
+ creation_status "reg_error"
+ creation_message {}
+ element_messages {}
+ account_status "ok"
+ account_message {}
+ }
+
+ # TODO: email = username
+ # TODO: Add catch
+
+ set user_id [ad_user_new \
+ $email \
+ $first_names \
+ $last_name \
+ $password \
+ $question \
+ $answer \
+ $url \
+ $email_verified_p \
+ $member_state \
+ "" \
+ $username \
+ $authority_id]
+
+ if { !$user_id } {
+ set result(creation_status) "fail"
+ set result(creation_message) "We experienced an error while trying to register an account for you."
+ return [array get result]
+ }
+
+ # Creation succeeded
+ set result(creation_status) "ok"
+
+ # TODO: validate data (see user-new-2.tcl)
+ # TODO: double-click protection
+
+ # Get whether they requre some sort of approval
+ if { [parameter::get -parameter RegistrationRequiresApprovalP -default 0] } {
+ set member_state "needs approval"
+ set result(account_status) "closed"
+ set result(account_message) [_ acs-subsite.lt_Your_registration_is_]
+ } else {
+ set member_state "approved"
+ }
+
+ set notification_address [parameter::get -parameter NewRegistrationEmailAddress -default [ad_system_owner]]
+
+ if { [parameter::get -parameter RegistrationRequiresEmailVerificationP -default 0] } {
+ set email_verified_p "f"
+ set result(account_status) "closed"
+ set result(account_message) "[_ acs-subsite.lt_Registration_informat_1]
[_ acs-subsite.lt_Please_read_and_follo]
"
+
+ set row_id [db_string rowid_for_email {
+ select rowid from users where user_id = :user_id
+ }]
+
+ # Send email verification email to user
+ set confirmation_url "[ad_url]/register/email-confirm?[export_vars { row_id }]"
+ with_catch errmsg {
+ ns_sendmail \
+ $email \
+ $notification_address \
+ "[_ acs-subsite.lt_Welcome_to_system_nam]" \
+ "[_ acs-subsite.lt_To_confirm_your_regis]"
+ } {
+ ns_returnerror "500" "$errmsg"
+ ns_log Warning "Error sending email verification email to $email. Error: $errmsg"
+ }
+
+ } else {
+ set email_verified_p "t"
+ }
+
+ # Send password/confirmail email to user
+ if { [parameter::get -parameter RegistrationProvidesRandomPasswordP -default 0] || \
+ [parameter::get -parameter EmailRegistrationConfirmationToUserP -default 0] } {
+ with_catch errmsg {
+ ns_sendmail \
+ $email \
+ $notification_address \
+ "[_ acs-subsite.lt_Welcome_to_system_nam]" \
+ "[_ acs-subsite.lt_Thank_you_for_visitin]"
+ } {
+ ns_returnerror "500" "$errmsg"
+ ns_log Warning "Error sending registration confirmation to $email. Error: $errmsg"
+ }
+ }
+
+ # Notify admin on new registration
+ if {[ad_parameter NotifyAdminOfNewRegistrationsP "security" 0]} {
+ with_catch errmsg {
+ ns_sendmail \
+ $notification_address \
+ $email \
+ "[_ acs-subsite.lt_New_registration_at_s]" \
+ "[_ acs-subsite.lt_first_names_last_name]"
+ } {
+ ns_returnerror "500" "$errmsg"
+ ns_log Warning "Error sending admin notification to $notification_address. Error: $errmsg"
+ }
+ }
+
+
+ return [array get result]
+}
+
+ad_proc -private auth::local::registration::GetParameters {} {
+ Implements the GetParameters operation of the auth_registration
+ service contract for the local account implementation.
+} {
+ # No parameters
+ return [list]
+}
Index: openacs-4/packages/acs-authentication/tcl/test/acs-authentication-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-authentication/tcl/test/acs-authentication-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-authentication/tcl/test/acs-authentication-procs.tcl 22 Aug 2003 10:55:00 -0000 1.1
@@ -0,0 +1,22 @@
+ad_library {
+ Register acs-automated-testing test cases for the workflow
+ package on server startup.
+
+ @author Peter Marklund
+ @creation-date 21 August 2003
+ @cvs-id $Id: acs-authentication-procs.tcl,v 1.1 2003/08/22 10:55:00 simonc Exp $
+}
+
+aa_register_case auth_authenticate {
+ Test the auth::authenticate proc.
+
+ @author Peter Marklund
+} {
+ # Successful authentication
+
+ # Failed authentications
+
+ # Closed account status
+
+ # Error handling
+}