- Publicity: Public Only All
oauth-server-procs.tcl
OAuth Server
- Location:
- packages/xooauth/tcl/oauth-server-procs.tcl
- Created:
- 2012 Translation to XOTcl2: Gustaf Neumann
- Author:
- Michael Aram
Procedures in this file
Detailed information
[ hide source ] | [ make this the default ]Content File Source
::xo::library doc { OAuth Server @author Michael Aram @creation-date 2012 Translation to XOTcl2: Gustaf Neumann } if {0} { namespace eval ::xo::oauth { # # OAuth Server Mixin Class # Class create Server Server ad_instproc server_metadata {} { Server metadata } { set :server_metadata_id [:require_server_metadata] :log "I retrieved the sm: ${:server_metadata_id}" set server [::xo::db::CrClass get_instance_from_db -item_id ${:server_metadata_id}] :log "" return $server } Server ad_instproc require_server_metadata {} { Require server metadata } { set parent_id ${:folder_id} set server_metadata_id [ns_cache eval xotcl_object_type_cache xooauth_server_metadata-${:id} { set server_metadata_id [::xo::db::CrClass lookup \ -name xooauth_server_metadata \ -parent_id $parent_id] if {$server_metadata_id == 0} { :log "This package has no server metadata yet." set system_url [ad_url] set server_metadata [::xo::oauth::ServerMetadata new \ -name xooauth_server_metadata \ -parent_id $parent_id \ -package_id ${:id} \ -temp_credentials_url "${system_url}/oauth/initiate" \ -token_credentials_url "${system_url}/oauth/token" \ -authorization_url "${system_url}/oauth/authorize"] $server_metadata save_new set server_metadata_id [$server_metadata item_id] :log "Created XOOAuth Server metadata for package ${:id} in folder $parent_id" } :log "returning from cache server_metadata_id $server_metadata_id" return $server_metadata_id }] #my log "returning from require server_metadata_id $server_metadata_id" return $server_metadata_id } # # Methods exposed via the web interface. # Server instproc initiate {} { # TODO: This URL must be only accessible via HTTPS if {[:verify_incoming_request]} { # We have a valid request set client_identifier [:request_parameter oauth_consumer_key] set callback [:request_parameter oauth_callback] set client_credentials [:get_credentials -identifier $client_identifier] set parent_id ${:folder_id} set temporary_credentials [TempCredentials new \ -identifier [ad_generate_random_string] \ -parent_id $parent_id \ -secret [ad_generate_random_string] \ -callback $callback \ -server_metadata_id [[:server_metadata] item_id] \ -client_metadata_id [$client_credentials client_metadata_id]] $temporary_credentials save_new :log [$temporary_credentials serialize] set response_body "[$temporary_credentials as_encoded_string]&oauth_callback_confirmed=true" doc_return 200 "text/plain" $response_body # doc_return 200 "application/x-www-form-urlencoded" $response_body } else { doc_return 404 text/html "Not Authorized" } #set oauth_parameters [ProtocolParameters initialize_from_cc [:context]] #set response_body [$oauth_parameters serialize] #doc_return 200 text/html $response_body } Server ad_instproc authorize {} { @see http://tools.ietf.org/html/rfc5849#section-2.2 } { # TODO: Authorization Verifier ohne callback ermöglichen!! # TODO: Make a filter util_driver_info -array driver if {$driver(proto) ne "https"} { ns_log warning "OAuth must be used over SSL to be secure!" } auth::require_login set temp_cred_id [:request_parameter oauth_token] # TODO: Make this a parameter set adp /packages/xooauth/lib/authorize set :mime_type text/html set temp_credentials [:get_credentials \ -identifier $temp_cred_id \ -server [:server_metadata]] :log [$temp_credentials serialize] set client [$temp_credentials client_metadata_id] # Generate a verifier for the temporary credential. set oauth_verifier [ad_generate_random_string] $temp_credentials verifier $oauth_verifier #TODO: Can we avoid this save? #TODO: Is it semantically correct to: # a) generate a new verifier upon each incoming request? # b) generate it once and complain upon any other request? # note: it IS better to save it here instead of upon form submit, # because otherwise - without submit - the verifier would not go to # the db... $temp_credentials save :return_page -adp $adp -variables { client temp_credentials } } Server ad_instproc token {} { Token credentials } { # TODO: This URL must be only accessible via HTTPS if {[:verify_incoming_request]} { # We have a valid request set client_credentials [:credentials_from_request_parameter oauth_consumer_key] set temporary_credentials [:credentials_from_request_parameter oauth_token] #TODO: Verify the incoming verifier set parent_id ${:folder_id} set token_credentials [TokenCredentials new \ -parent_id $parent_id \ -identifier [ad_generate_random_string] \ -secret [ad_generate_random_string] \ -client [$client_credentials client]] $token_credentials save_new :log [$token_credentials serialize] set response_body "[$token_credentials as_encoded_string]" doc_return 200 "text/plain" $response_body # doc_return 200 "application/x-www-form-urlencoded" $response_body } else { doc_return 404 text/html "Not Authorized" } #set oauth_parameters [ProtocolParameters initialize_from_cc [:context]] #set response_body [$oauth_parameters serialize] #doc_return 200 text/html $response_body } Server instproc credentials_from_request_parameter {p} { set identifier [:request_parameter $p] set credentials [:get_credentials -identifier $identifier] return $credentials } Server ad_instproc get_credentials { {-identifier} {-server ""} {-client ""} } { Get credentials } { # TODO: Replace with ::xo::db-layer code set sql " SELECT DISTINCT item_id FROM [Credentials table_name]x WHERE identifier = :identifier " if {$client ne ""} { set client_metadata_id [$client item_id] append sql " AND client_metadata_id = :client_metadata_id " } if {$server ne ""} { set server_metadata_id [$server item_id] append sql " AND server_metadata_id = :server_metadata_id " } set item_id [xo::dc get_value [:qn select_item_id] $sql -default 0] if {!$item_id} { ad_return_complaint 0 \ "Could not fetch credentials for identifier '$identifier' and server '$server' and client '$client'" ad_script_abort } set instance [::xo::db::CrClass get_instance_from_db -item_id $item_id] return $instance } Server ad_instproc request_parameter { {-override_empty_values false} name {default ""} } { Request parameter } { set authorization_header_parameter [:authorization_header_parameter $name $default] #my log "AAAAAAA $name - $default - $authorization_header_parameter" if {$authorization_header_parameter ne $default} { return $authorization_header_parameter } set form_parameter [[:context] form_parameter $name $default] if {$form_parameter ne $default && (!$override_empty_values || $form_parameter ne "")} { return $form_parameter } set query_parameter [[:context] query_parameter $name $default] if {$query_parameter ne $default && (!$override_empty_values || $query_parameter ne "")} { return $query_parameter } return $default } Server instproc authorization_header_parameter {name {default ""}} { if {[:exists_authorization_header_parameter $name]} { #my log "Yes, the parameter $name seems to exist in [ns_set get [ns_conn headers] Authorization]" foreach parameter_pair [:get_authorization_header_parameters] { lassign $parameter_pair key value #my log "Testing $key against $name" if {$key eq $name} { #my log "Returning $value" return $value } } } else { #my log "No, the parameter $name seems not to exist in [ns_set get [ns_conn headers] Authorization]" return $default } } Server instproc exists_request_parameter {name} { if {[:exists_authorization_header_parameter $name]} { return 1 } if {[[:context] exists_form_parameter $name]} { return 1 } if {[[:context] exists_query_parameter $name]} { return 1 } return 0 } Server instproc exists_authorization_header_parameter {name} { foreach parameter_pair [:get_authorization_header_parameters] { lassign $parameter_pair key value #my log "KEY: $key VALUE: $value" if {$key eq $name} { return 1 } } return 0 } # # Private methods # Server ad_instproc privilege=oauth {{-login true} user_id package_id method} { This method implements a privilege for the xotcl-core permission system, so that one is able to protect methods via policies. For example: <pre> Class create Package -array set require_permission { view {{id read}} protected-service oauth } </pre> } { #my log "Validating OAuth signature" set signature_is_valid [:verify_incoming_request] return $signature_is_valid } Server ad_instproc verify_incoming_request {} { @see http://tools.ietf.org/html/rfc5849#section-3.2 } { # Verify signature set client_signature [:request_parameter oauth_signature] if {$client_signature eq ""} { :log "Cannot verify request - no signature provided" doc_return 401 text/plain "Unauthorized. Unsigned request!" ad_script_abort return 0 } set client_identifier [:request_parameter oauth_consumer_key] set client_credentials [:get_credentials -identifier $client_identifier -server [:server_metadata]] if {$client_credentials eq ""} { :log "Cannot verify request - no client credentials found" doc_return 401 text/plain "Unauthorized. Client unknown!" ad_script_abort return 0 } # BEWARE: This puts secrets into the log file! #my log "Client credentials: [$client_credentials serialize]" # see http://tools.ietf.org/html/rfc5849#appendix-A set has_non_empty_token [expr {[:exists_request_parameter oauth_token] && [:request_parameter oauth_token] ne ""}] if {$has_non_empty_token} { set token_identifier [:request_parameter oauth_token] set token_credentials [:get_credentials -identifier $token_identifier] } set server_signature_object [Signature new \ -volatile \ -request_method [ns_conn method] \ -base_string_uri [:generate_signature_uri] \ -client_secret [$client_credentials secret] \ -signature_parameters [:collect_signature_parameters] ] $server_signature_object lappend signature_parameters [list oauth_consumer_secret [$client_credentials secret]] if {$has_non_empty_token} { $server_signature_object token_secret [$token_credentials secret] $server_signature_object lappend signature_parameters [list oauth_token_secret [$token_credentials secret]] } set server_signature [$server_signature_object generate] if {$server_signature ne $client_signature} { :log "Unauthorized. Signatures do NOT match! \nServer Signature: $server_signature \nClient Signature: $client_signature" doc_return 401 text/plain "Unauthorized. Signatures do not match!" ad_script_abort return 0 } else { :log "Signatures do match: Server Signature: $server_signature Client Signature: $client_signature" } # TODO: Verify combination of nonce/timestamp/token has not been used before # TODO: Verify scope and status of client authorization # TODO: Verify oauth_version is 1.0 # We reached this point- seems to be a valid request return 1 #set response_body [$oauth_parameters serialize] #doc_return 200 text/html $response_body } Server instproc generate_signature_uri {} { # The port MUST be omitted, if it is the standard port (80/443) # and it MUST be included if it is any other port. #set host_header [string tolower [ns_set get [ns_conn headers] Host]] #set scheme [expr {[security::secure_conn_p] ? "https" : "http"}] set host_header [ad_url] regexp {^(https?)://(.*):?([^:]*)$} $host_header _ scheme host port regexp {^(https?)://([^:/]*):?([0-9]*)?} $host_header _ scheme host port set path_query_fragment [ns_conn url] #my log ----$path_query_fragment # Strip eventual query parameters from path set info [uri::split $path_query_fragment] set path [dict get $info path] # uri::join also omits default ports, as required by OAuth set base_string_uri [uri::join scheme $scheme host $host port $port path $path] #my log "set base_string_uri uri::join scheme $scheme host $host port $port path $path" return $base_string_uri } Server ad_instproc decode {s} { URL decode } { return [::xo::oauth::utility urldecode $s] } Server ad_instproc get_authorization_header_parameters {} { Gathers OAuth parameters from the "Authorization" header of the incoming request. } { set parameter_pairs [list] set authorization_header [ns_set get [ns_conn headers] Authorization] set authorization_header [regsub {OAuth } $authorization_header ""] set authorization_header_parameters [split $authorization_header ,] foreach parameter_pair $authorization_header_parameters { foreach {key value} [split $parameter_pair =] { set value [string range $value 1 end-1] lappend parameter_pairs [list [:decode [string trim $key]] [:decode [string trim $value]]] #my log "lappend parameter_pairs [list [string trim $key] [string trim $value]]" #my log "lappend parameter_pairs [list [:decode [string trim $key]] [:decode [string trim $value]]]" } } return $parameter_pairs } Server ad_instproc collect_signature_parameters {} { Gathers the parameters to be signed from the incoming request. } { set cc [:context] #array set uri [uri::split [:url]] set parameter_pair_list [list] set query_parameter_list [list] # These parameters did not come from outside, but were set # during initialization of the package (index.vuh) set omit_parameter_list [list] foreach p [::xo::cc parameter_declaration] { # Turn something like "-folder_id:integer" into "folder_id" lappend omit_parameter_list [regsub {^-} [lindex [split [lindex $p 0] :] 0] ""] } # Step 1: Get query parameters foreach {key value} [$cc get_all_query_parameter] { if {[lsearch $omit_parameter_list $key] ne -1} continue lappend parameter_pair_list [list $key $value] lappend query_parameter_list [list $key] } # Step 2: Get Authorization Header #my log "Before appending from header: $parameter_pair_list" lappend parameter_pair_list {*}[:get_authorization_header_parameters] :log "After appending from header: $parameter_pair_list" # Step 3: Get Entity Body set content_type_header [ns_set get [ns_conn headers] Content-Type] if {[string match "*x-www-form-urlencoded*" $content_type_header]} { foreach {key value} [$cc get_all_form_parameter] { # NaviServer already decodes the parameter values before XOTcl Core # adds them as list to its form_parameters array. Therefore, when we # send a parameter mypar=A%20B to the server, we end up with a list # in the value variable here. :log "DEBUG $key - $value" if {[lsearch $query_parameter_list [:decode $key]] ne -1} continue lappend parameter_pair_list [list [:decode $key] {*}[:decode $value]] } :log "After appending from form: $parameter_pair_list" } set filtered_parameter_pair_list [list] :log "Retrieved Parameters" foreach pair $parameter_pair_list { foreach {key value} $pair { if {$key eq "oauth_signature"} continue if {$key eq "realm"} continue lappend filtered_parameter_pair_list $pair :log "Retrieved Name: $key Value: $value" } } return $filtered_parameter_pair_list } } } ::xo::library source_dependent # # Local variables: # mode: tcl # tcl-indent-level: 2 # indent-tabs-mode: nil # End: