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: + + + + @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 +}