+XOOAUTH
Index: openacs-4/packages/xooauth/tcl/oauth-client-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xooauth/tcl/Attic/oauth-client-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xooauth/tcl/oauth-client-procs.tcl 7 Nov 2020 17:58:25 -0000 1.1.2.1
@@ -0,0 +1,143 @@
+::xo::library doc {
+ OAuth Client
+
+ @author Michael Aram
+ @creation-date 2012
+
+ Translation to XOTcl2:
+ Gustaf Neumann
+}
+
+if {0} {
+namespace eval ::xo::oauth {
+
+ #
+ # OAuth Client Mixin Class
+ #
+
+ Class create Client -parameter remote_server -ad_doc {
+ @param server_metadata The information about the servers endpoint to
+ which the client shall connect.
+ @param client_credentials The credentials of this client as stored
+ at the server side.
+ }
+
+ #Client ad_instproc set_remote_server {server_metadata} {} {
+ # set :remote_server $server_metadata
+ #}
+
+ Client ad_instproc client_metadata {} {} {
+ set :client_metadata_id [:require_client_metadata]
+ set client [::xo::db::CrClass get_instance_from_db -item_id ${:client_metadata_id}]
+ return $client
+ }
+
+ Client ad_instproc require_client_metadata {} {
+ This method stores an OAuth client metadata record for the
+ current xo-package. Packages, that act as client will store
+ this metadata record for the temp_credentials it retrieves
+ from servers.
+ @return Returns the item id of the record created or retrieved from cache.
+ } {
+ set parent_id ${:folder_id}
+ set client_metadata_id [ns_cache eval xotcl_object_type_cache xooauth_client_metadata-${:id} {
+ set client_metadata_id [::xo::db::CrClass lookup \
+ -name xooauth_client_metadata \
+ -parent_id $parent_id]
+ if {$client_metadata_id == 0} {
+ :log "This package has no client metadata yet."
+ set client_metadata [::xo::oauth::ClientMetadata new \
+ -name xooauth_client_metadata \
+ -parent_id $parent_id \
+ -package_id ${:id}]
+ $client_metadata save_new
+ set client_metadata_id [$client_metadata item_id]
+ :log "Created XOOAuth Client metadata for package ${:id} in folder $parent_id"
+ }
+ :log "returning from cache client_metadata_id $client_metadata_id"
+ return $client_metadata_id
+ }]
+ #:log "returning from require client_metadata_id $client_metadata_id"
+ return $client_metadata_id
+ }
+
+ Client ad_instproc get_temp_credentials {} {} {
+ if {${:remote_server} eq ""} {
+ error "no remote server"
+ }
+ ${:remote_server} instvar {item_id server_id} temp_credentials_url authorization_url
+ set consumer_key [${:remote_server} consumer_key]
+ set consumer_secret [${:remote_server} consumer_secret]
+ #:msg [${:remote_server} serialize]
+ :msg "$consumer_key - $consumer_secret"
+ set callback [:package_url]/callback
+ #set callback http://shell.itec.km.co.at/oauth/callback
+ set r [::xo::oauth::AuthenticatedRequest from_oauth_parameters \
+ -url $temp_credentials_url \
+ -consumer_key $consumer_key \
+ -consumer_secret $consumer_secret \
+ -callback $callback]
+ :log [$r serialize]
+ if {[$r set status_code] eq 200} {
+ [:context] load_form_parameter
+ #TODO: Also used by server - make a method
+ #TODO - Replace with a regexp
+ foreach pair [split [$r set data] &] {
+ lassign [split $pair =] key value
+ set creds($key) [:decode $value]
+ :log "set creds($key) [:decode $value]"
+ }
+ set identifier $creds(oauth_token)
+ set secret $creds(oauth_token_secret)
+ set temp_credentials [TempCredentials new \
+ -parent_id ${:folder_id} \
+ -identifier $identifier \
+ -secret $secret \
+ -server_metadata_id $server_id \
+ -client_metadata_id [${:client_metadata} client_id]]
+ $temp_credentials save_new
+ set redirect_url [export_vars -base $authorization_url [list [list oauth_token $identifier]]]
+ ad_returnredirect -allow_complete_url $redirect_url
+ ad_script_abort
+ } else {
+ error "Server did not response with 200 OK"
+ }
+ }
+
+ Client ad_instproc callback {} {} {
+ set client ${:client_metadata}
+ set temp_cred_identifier [:request_parameter oauth_token]
+ set temporary_credentials [:get_credentials \
+ -identifier $temp_cred_identifier \
+ -client ${:client_metadata}]
+ set server [$temporary_credentials server]
+
+ set r [::xo::oauth::AuthenticatedRequest from_oauth_parameters \
+ -url [$server token_credentials_url] \
+ -consumer_key [$client consumer_key] \
+ -consumer_secret [$client consumer_secret] \
+ -callback [$temporary_credentials callback]]
+ #TODO: oauth_token_confirmed
+ set token_credentials [TokenCredentials new \
+ -parent_id ${:folder_id} \
+ -identifier [ad_generate_random_string] \
+ -secret [ad_generate_random_string] \
+ -client [$client_credentials client]]
+ }
+
+ Client ad_instproc authorize {} {} {
+ }
+
+ Client ad_instproc token {} {} {
+ }
+
+
+}
+}
+
+#
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 2
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/xooauth/tcl/oauth-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xooauth/tcl/Attic/oauth-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xooauth/tcl/oauth-procs.tcl 7 Nov 2020 17:58:25 -0000 1.1.2.1
@@ -0,0 +1,750 @@
+::xo::library doc {
+ XOTcl OAuth Library for OpenACS
+
+ This library strives to provide a comprehensive implementation
+ of the OAuth 1.0a protocol (RFC 5849) for OpenACS. Currently,
+ it supports signed requests using HMAC-SHA1.
+
+ @see http://tools.ietf.org/html/rfc5849
+
+ @author Michael Aram
+ @creation-date 2012-01
+
+ This work has been partly influenced by:
+ * Guan Yang - guan@unicast.org
+ * https://github.com/horgh/twitter-tcl
+
+ Translation to XOTcl2:
+ Gustaf Neumann
+}
+
+namespace eval ::xo {}
+namespace eval ::xo::oauth {
+
+ ad_proc nonce {} {} {
+ return [ad_generate_random_string 33]
+ }
+
+ ad_proc timestamp {} {} {
+ return [clock seconds]
+ }
+
+ #
+ # OAuth Server Metadata
+ #
+
+ ::xo::db::CrClass create ServerMetadata \
+ -superclass ::xo::db::CrItem \
+ -pretty_name "OAuth Server Metadata" \
+ -table_name "xooauth_server_metadata" \
+ -id_column "server_metadata_id" \
+ -mime_type text/plain \
+ -slots {
+ ::xo::db::CrAttribute create temp_credentials_url
+ ::xo::db::CrAttribute create authorization_url
+ ::xo::db::CrAttribute create token_credentials_url
+ } \
+ -ad_doc {
+ Server Metadata is typically stored at the client side
+ @see http://tools.ietf.org/html/rfc5849#section-1.2
+ }
+
+ #ServerMetadata instproc initialize_loaded_object {} {
+ # if {[info exists :client_credentials_id] && [:client_credentials_id] ne ""} {
+ # # For convenience, we make sure that the client is available as
+ # # an object via its canonical name.
+ # :msg "::xo::db::CrClass get_instance_from_db -item_id [:client_credentials_id]"
+ # ::xo::db::CrClass get_instance_from_db -item_id [:client_credentials_id]
+ # }
+ # next
+ #}
+
+ #ServerMetadata ad_instproc consumer_key {} {} {
+ # return [:client_credentials_id] identifier
+ #}
+
+ #ServerMetadata ad_instproc consumer_secret {} {} {
+ # return [:client_credentials_id] secret
+ #}
+
+ #
+ # OAuth Client Metadata
+ #
+
+ ::xo::db::CrClass create ClientMetadata \
+ -superclass ::xo::db::CrItem \
+ -pretty_name "OAuth Client Metadata" \
+ -table_name "xooauth_client_metadata" \
+ -id_column "client_metadata_id" \
+ -mime_type text/plain \
+ -ad_doc {
+ Client Metadata is typically stored at the server side.
+ @see http://tools.ietf.org/html/rfc5849#section-1.1
+ }
+
+ #ClientMetadata ad_instproc consumer_key {} {} {
+ # return [:client_credentials_id] identifier
+ #}
+
+ #ClientMetadata ad_instproc consumer_secret {} {} {
+ # return [:client_credentials_id] secret
+ #}
+
+ #
+ # OAuth Credentials
+ #
+
+ ::xo::db::CrClass create Credentials \
+ -superclass ::xo::db::CrItem \
+ -pretty_name "OAuth Credentials" \
+ -table_name "xooauth_credentials" \
+ -id_column "credentials_id" \
+ -mime_type text/plain \
+ -slots {
+ ::xo::db::CrAttribute create identifier
+ ::xo::db::CrAttribute create secret
+ ::xo::db::CrAttribute create client_metadata_id \
+ -datatype integer \
+ -references "cr_items(item_id) on delete cascade"
+ ::xo::db::CrAttribute create server_metadata_id \
+ -datatype integer \
+ -references "cr_items(item_id) on delete cascade"
+ } \
+ -ad_doc {
+ All credentials are unique only between a client-server pair,
+ which is the reason to store the client and server id at this
+ level.
+ @see http://tools.ietf.org/html/rfc5849#section-1.1
+ }
+
+ # Credentials proc get_instance_from_identifier {identifier} {
+ # set item_id [xo::dc get_value [:qn select_item_id] "
+ # SELECT DISTINCT item_id
+ # FROM [:table_name]x
+ # WHERE identifier = :identifier
+ # " -default 0]
+ # if {!$item_id} {error "Could not fetch credentials"}
+ # set instance [::xo::db::CrClass get_instance_from_db -item_id $item_id]
+ # return $instance
+ # }
+
+ Credentials instproc as_encoded_string {} {
+ set oauth_token [::xo::oauth::utility urlencode ${:identifier}]
+ set oauth_token_secret [::xo::oauth::utility urlencode ${:secret}]
+ return "oauth_token=${oauth_token}&oauth_token_secret=${oauth_token_secret}"
+ }
+
+ ::xo::db::CrClass create ClientCredentials \
+ -superclass ::xo::oauth::Credentials \
+ -pretty_name "OAuth Client Credentials" \
+ -table_name "xooauth_client_credentials" \
+ -id_column "client_credentials_id" \
+ -mime_type text/plain
+
+ # ClientCredentials instproc initialize_loaded_object {} {
+ # if {[info exists :client_metadata_id]} {
+ # # For convenience, we make sure that the client is available as
+ # # an object via its canonical name.
+ # ::xo::db::CrClass get_instance_from_db -item_id [:client_metadata_id]
+ # }
+ # next
+ # }
+
+ ::xo::db::CrClass create TempCredentials \
+ -superclass ::xo::oauth::Credentials \
+ -pretty_name "OAuth Temporary Credentials" \
+ -table_name "xooauth_temp_credentials" \
+ -id_column "temp_credentials_id" \
+ -mime_type text/plain \
+ -slots {
+ ::xo::db::CrAttribute create callback \
+ -datatype text \
+ -required false
+ ::xo::db::CrAttribute create verifier \
+ -datatype text \
+ -required false
+ } \
+ -ad_doc {
+ @see http://tools.ietf.org/html/rfc5849#section-1.1
+ }
+
+ # TempCredentials instproc initialize_loaded_object {} {
+ # if {[info exists :server_metadata_id]} {
+ # # For convenience, we make sure that the client is available as
+ # # an object via its canonical name.
+ # ::xo::db::CrClass get_instance_from_db -item_id [:server_metadata_id]
+ # }
+ # if {[info exists :client_metadata_id]} {
+ # # For convenience, we make sure that the client is available as
+ # # an object via its canonical name.
+ # ::xo::db::CrClass get_instance_from_db -item_id [:client_metadata_id]
+ # }
+ # next
+ # }
+
+ ::xo::db::CrClass create TokenCredentials \
+ -superclass ::xo::oauth::Credentials \
+ -pretty_name "OAuth Token Credentials" \
+ -table_name "xooauth_token_credentials" \
+ -id_column "token_credentials_id" \
+ -mime_type text/plain \
+ -ad_doc {
+ @see http://tools.ietf.org/html/rfc5849#section-1.1
+ }
+
+ #
+ # Signature
+ #
+
+ Class create Signature -parameter {
+ {request_method "POST"}
+ base_string_uri
+ signature_parameters
+ client_secret
+ {token_secret ""}
+ } -ad_doc {
+ @param protocol_parameters Expects a list of key-value pairs representing parameters of different sources.
+ }
+
+ Signature ad_proc base_string_from_url {uri} {
+ This procedure transforms a given URL into a format that
+ is conformant to "http://tools.ietf.org/html/rfc5849#section-3.4.1.2".
+ Most importantly, it strips any query part from the URL.
+ } {
+ array set "" [uri::split $uri]
+ set base_string_uri [uri::join scheme $(scheme) host $(host) port $(port) path $(path)]
+ return $base_string_uri
+ }
+
+ Signature instproc construct_base_string {} {
+ # @see http://tools.ietf.org/html/rfc3986#section-3.1
+ append sbs [:encode [string toupper [:request_method]]]
+ append sbs "&"
+ append sbs [:encode [:base_string_uri]]
+ append sbs "&"
+ append sbs [:normalize_parameters]
+ #:log "Signature Base String:\n$sbs"
+ return $sbs
+ }
+
+ Signature instproc normalize_parameters {} {
+ set parameter_pair_list [:signature_parameters]
+ foreach pair $parameter_pair_list {
+ lassign $pair key value
+ if {[string match "*secret" $key]} continue
+ lappend encoded_parameter_pair_list [list [:encode $key] [:encode $value]]
+ }
+ #ns_log notice "encoded_parameter_pair_list $encoded_parameter_pair_list"
+ foreach pair $encoded_parameter_pair_list {
+ lassign $pair key value
+ lappend concatenated_parameter_list [list ${key}=${value}]
+ }
+ # Note: OAuth requires the parameters to be sorted first by name and then,
+ # if two parameters have the same name, by value. So instead of sorting
+ # twice here, we just sort the concatenated value (e.g. a=b) as a whole.
+ # I hope I have no error in reasoning here...
+ # set sorted_parameter_pair_list [lsort -index 0 $encoded_parameter_pair_list]
+ set sorted_concatenated_parameter_list [lsort $concatenated_parameter_list]
+ #:log "Sorted Concatenated Parameters"
+ #foreach pair $sorted_concatenated_parameter_list {
+ # foreach {key value} $pair {
+ # :log "Name: $key Value: $value"
+ # }
+ #}
+
+ set normalized_parameters [join $sorted_concatenated_parameter_list &]
+ set encoded_normalized_parameters [:encode $normalized_parameters]
+ return $encoded_normalized_parameters
+ }
+
+ Signature instproc generate {} {
+
+ set signature_base_string [:construct_base_string]
+
+ append hmac_sha1_key [:encode ${:client_secret}]
+ append hmac_sha1_key &
+ append hmac_sha1_key [:encode ${:token_secret}]
+
+ #package require sha1
+ #set hmac_sha1_digest [sha1::hmac -bin -key $hmac_sha1_key $signature_base_string]
+ #set oauth_signature_parameter [base64::encode $hmac_sha1_digest]
+
+ set oauth_signature_parameter [ns_crypto::hmac string \
+ -binary \
+ -digest sha1 \
+ -encoding base64 \
+ $hmac_sha1_key $base_string]
+
+ # FIXME - TODO: It seems, as if the LTI tool provider under
+ # http://www.imsglobal.org/developers/BLTI/tool.php does not accept a URL-encoded
+ # encoding of the SBS. However, - if I remember correctly - Twitter wants
+ # us to encode that here... Needs further checking...
+ #set oauth_signature_parameter [:encode $oauth_signature_parameter]
+
+ return $oauth_signature_parameter
+ }
+
+ Signature ad_instproc encode {s} {
+ @see http://tools.ietf.org/html/rfc5849#section-3.6
+ } {
+ #return [::xowiki::utility urlencode $s]
+ return [::xo::oauth::utility urlencode $s]
+ }
+
+ if {0} {
+ #
+ # Authenticated Requests
+ #
+
+ Class create AuthenticatedRequest -superclass ::xo::HttpCore -parameter {
+ {client_credentials ""}
+ {token_credentials ""}
+ {protocol_parameters ""}
+ {transmission "header"}
+ } -ad_doc {
+ Conceptually, an OAuth authenticated request is a normal HTTP
+ request with additional parameters, which are used to proof the
+ authentication of the sender when requesting a protected resource.
+
+ There are three ways to setup an authenticated request using this
+ class:
+
+ * Provide only credentials, any additional required parameters are
+ initialized for you.
+ * Provide credentials and additional parameters, e.g. if you want
+ to provide a realm. In case of ambiguity, credential identifiers
+ provided here override those provided in the protocol parameter
+ data structure.
+ * Provide full-fledged protocol parameters, which are included
+ "as is" for the request. This can be useful, when all parameters
+ are known, e.g. when testing the Twitter API using parameters
+ provided by Twitter.
+
+ @protocol_parameters If provided here, these parameters are used
+ to override OAuth protocol parameters which are usually optional
+ or automatically set.
+ @see http://tools.ietf.org/html/rfc5849#section-3
+ }
+
+ AuthenticatedRequest ad_proc from_oauth_parameters {
+ {-realm}
+ {-consumer_key ""}
+ {-consumer_secret ""}
+ {-token ""}
+ {-token_secret ""}
+ {-signature_method "HMAC-SHA1"}
+ {-timestamp}
+ {-nonce}
+ {-version "1.0"}
+ {-signature}
+ {-callback ""}
+ {-verifier ""}
+ {-url}
+ {-query_parameter_list {}}
+ {-post_data ""}
+ {-transmission "header"}
+ {-content_type "application/x-www-form-urlencoded; charset=UTF-8"}
+ } {
+
+ Attention: Note that any URL query parameters provided to this method
+ should NOT be encoded via export_vars, but instead via the -query_parameter_list parameter
+ # TODO: provide a parameter -query_parameter_list which handles this for us...
+
+ Convenience method for creating a request. Here, the parameter names
+ are following the community edition (and not the RFC terminology).
+ #TODO: This is alpha!!
+ @param callback The OAuth client's (unencoded) callback URI, to which
+ the server shall send the authorization verification.
+ @param transmission One of header, body, uri
+ } {
+ if {$query_parameter_list ne ""} {
+ set pairs {}
+ foreach {qpk qpv} $query_parameter_list {
+ lappend pairs [::xo::oauth::utility urlencode $qpk]=[::xo::oauth::utility urlencode $qpv]
+ }
+ append url ?[join $pairs &]
+ }
+ set r [::xo::oauth::AuthenticatedRequest new -url $url]
+ if {$post_data ne ""} {
+ $r post_data $post_data
+ $r method POST
+ $r content_type $content_type
+ }
+ if {$consumer_key ne ""} {
+ set client_credentials [::xo::oauth::Credentials new \
+ -identifier $consumer_key \
+ -secret $consumer_secret]
+ $r client_credentials $client_credentials
+ }
+ if {$token ne ""} {
+ set token_credentials [::xo::oauth::Credentials new \
+ -identifier $token \
+ -secret $token_secret]
+ $r token_credentials $token_credentials
+ }
+ set callback [::xo::oauth::utility urlencode $callback]
+ set protocol_parameters [ProtocolParameters new]
+ foreach p {verifier callback} {
+ if {[set $p] ne ""} {
+ $protocol_parameters oauth_$p [set $p]
+ }
+ }
+ $r protocol_parameters $protocol_parameters
+ $r transmission $transmission
+ if {$transmission eq "body"} {
+ $r content_type "application/x-www-form-urlencoded"
+ }
+ $r send
+ #:log [$r serialize]
+ return $r
+ }
+
+ # Uncomment for debugging
+ # AuthenticatedRequest instmixin add ::xo::HttpRequestTrace
+ #
+ #
+
+ AuthenticatedRequest ad_instproc send {} {} {
+ :initialize
+ :send_request
+ }
+
+ AuthenticatedRequest instproc initialize {} {
+ if {$protocol_parameters eq ""} {
+ :initialize_protocol_parameters
+ } elseif {[info exists :client_credentials]} {
+ ${:protocol_parameters} oauth_consumer_key [${:client_credentials} identifier]
+ if {${:token_credentials} ne ""} {
+ ${:protocol_parameters} oauth_token [${:token_credentials} identifier]
+ }
+ set signature_string [:generate_signature]
+ ${:protocol_parameters} oauth_signature $signature_string
+ :set_protocol_parameters ${:protocol_parameters}
+ }
+ }
+
+ AuthenticatedRequest ad_instproc set_protocol_parameters {p} {
+ } {
+ switch -- ${:transmission} {
+ "header" {
+ lappend :request_header_fields {*}[$p as_request_header_field]
+ }
+ body {
+ set :content_type "application/x-www-form-urlencoded"
+ #if {${:content_type} ne "application/x-www-form-urlencoded"} {
+ # error "Content Type MUST be application/x-www-form-urlencoded"
+ #}
+ set :post_data [join [list ${:post_data} [$p as_entity_body]] &]
+ }
+ default {
+ error "Transmission method not supported"
+ }
+ }
+ }
+
+ # TODO: Refactor ProtocolParameter initialization - provide a method
+ # initialize/decorate, which sets all values, that have not been set yet.
+ AuthenticatedRequest ad_instproc initialize_protocol_parameters {} {
+ Computes the protocol parameters and inserts them as an "Authorization Header"
+ into the request's header fields.
+ } {
+ set :protocol_parameters [ProtocolParameters new \
+ -oauth_consumer_key [${:client_credentials} identifier] ]
+ if {${:token_credentials} ne ""} {
+ ${:protocol_parameters} oauth_token [${:token_credentials} identifier]
+ }
+ # TODO: Theoretically, OAuth permits unsigned requests also
+ set signature_string [:generate_signature]
+ ${:protocol_parameters} oauth_signature $signature_string
+
+ #lappend :request_header_fields {*}[${:protocol_parameters} as_request_header_field]
+ :set_protocol_parameters ${:protocol_parameters}
+ }
+
+ AuthenticatedRequest instproc generate_signature {} {
+ # see http://tools.ietf.org/html/rfc5849#section-3.4.2
+ set signature [Signature new \
+ -volatile \
+ -request_method [:method] \
+ -base_string_uri [:generate_signature_uri] \
+ -signature_parameters [:collect_signature_parameters] \
+ -client_secret [${:client_credentials} secret]]
+
+ if {${:token_credentials} ne ""} {
+ $signature set token_secret [${:token_credentials} secret]
+ }
+ set oauth_signature_parameter [$signature generate]
+
+ return $oauth_signature_parameter
+ }
+
+ AuthenticatedRequest instproc generate_signature_uri {} {
+ set scheme [string tolower [:protocol]]
+ set host [string tolower [:host]]
+ set port [:port]
+ set path_query_fragment [:path]
+ # Strip eventual query parameters from path
+ array set "" [uri::split $path_query_fragment]
+ set path $(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]
+ #:log "set base_string_uri uri::join scheme $scheme host $host port $port path $path"
+ #set encoded_base_string_uri [:encode $base_string_uri]
+ return $base_string_uri
+ }
+
+ AuthenticatedRequest ad_instproc collect_signature_parameters {} {
+ @see http://tools.ietf.org/html/rfc5849#section-3.4.1.3
+ } {
+ array set uri [uri::split [:url]]
+ set parameter_pair_list [list]
+
+ # Step 1: Get query parameters
+ foreach pair [split $uri(query) &] {
+ lassign [split $pair =] key value
+ #:msg "parameter_list [list [ns_urldecode $key] [ns_urldecode $value]]"
+ lappend parameter_pair_list [list [:decode $key] [:decode $value]]
+ }
+
+ # Step 2: Get Authorization Header
+ foreach {key value} [${:protocol_parameters} get_signature_parameter_list] {
+ #:msg "parameter_list [list [ns_urldecode $key] [ns_urldecode $value]]"
+ lappend parameter_pair_list [list [:decode $key] [:decode $value]]
+ }
+
+ # Step 3: Get Entity Body
+ if {[string match "*x-www-form-urlencoded*" ${:content_type}]} {
+ if {${:post_data} ne ""} {
+ foreach pair [split ${:post_data} &] {
+ lassign [split $pair =] key value
+ #:msg "parameter_list [list [ns_urldecode $key] [ns_urldecode $value]]"
+ lappend parameter_pair_list [list [:decode $key] [:decode $value]]
+ }
+ }
+ }
+ #:log "Collected Parameters"
+ #foreach pair $parameter_pair_list {
+ # foreach {key value} $pair {
+ # :log "Collected Name: $key Value: $value"
+ # }
+ #}
+
+ return $parameter_pair_list
+ }
+
+ AuthenticatedRequest ad_instproc decode {s} {} {
+ # We cannot use urldecode, as this translates plusses to spaces.
+ #return [ns_urldecode $s]
+ return [::xo::oauth::utility urldecode $s]
+ }
+
+ AuthenticatedRequest ad_instproc encode {s} {
+ @see http://tools.ietf.org/html/rfc5849#section-3.6
+ } {
+ #return [::xowiki::utility urlencode $s]
+ return [::xo::oauth::utility urlencode $s]
+ }
+
+ #
+ # Protocol Parameters
+ #
+ Class create ProtocolParameters -parameter {
+ {realm}
+ {oauth_consumer_key}
+ {oauth_token ""}
+ {oauth_signature_method "HMAC-SHA1"}
+ {oauth_timestamp}
+ {oauth_nonce}
+ {oauth_version "1.0"}
+ {oauth_signature}
+ {oauth_callback}
+ {oauth_verifier}
+ } -ad_doc {
+
+ OAuth defines a set of protocol parameters, which have to be transmitted
+ in the authenticated requests. These parameters are typically included in
+ the "Authorization" HTTP header. This class defines this set of parameters
+ and provides vaious helper method for working with them.
+
+ @see http://tools.ietf.org/html/rfc5849#section-3.1
+ @see http://tools.ietf.org/html/rfc5849#section-2.1
+ }
+
+ # ProtocolParameters ad_proc initialize_from_cc {cc} {
+ # Build a ProtocolParameters object by collecting parameters from the connection context.
+ # } {
+ # foreach oauth_parameter [:info parameter] {
+ # # TODO: Allow query parameters also
+ # :log "set $oauth_parameter [$cc form_parameter $oauth_parameter]"
+ # set $oauth_parameter [$cc form_parameter $oauth_parameter]
+ # }
+ # set oauth_parameters [ProtocolParameters new \
+ # -oauth_consumer_key $oauth_consumer_key -oauth_token $oauth_consumer_key ]
+ # }
+
+ ProtocolParameters instproc init {} {
+ if {${:oauth_signature_method} ni {"HMAC-SHA1" "HMAC-RSA" "PLAINTEXT"}} error
+ if {${:oauth_version} ne "1.0"} error
+
+ if {![info exists :oauth_timestamp]
+ && ${:oauth_signature_method} ne "PLAINTEXT"
+ } {
+ set :oauth_timestamp [clock seconds]
+ }
+ if {![info exists :oauth_nonce]
+ && $signature_method ne "PLAINTEXT"
+ } {
+ set :oauth_nonce [ad_generate_random_string 33]
+ }
+ }
+
+ ProtocolParameters instproc oauth_parameters {} {
+ # We could use an enumeration instead - would be faster...
+ set parameter_keys [list]
+ foreach parameter_definition [[:info class] info parameter] {
+ lappend parameter_keys [lindex $parameter_definition 0]
+ }
+ return $parameter_keys
+ }
+
+ ProtocolParameters instproc oauth_signature_parameters {} {
+ # We use all parameters except signature and realm...
+ set sig_paras [lsearch -inline -all -not -exact [:oauth_parameters] oauth_signature]
+ set sig_paras [lsearch -inline -all -not -exact $sig_paras realm]
+ return $sig_paras
+ }
+
+ ProtocolParameters instproc as_request_header_field {} {
+ return [list Authorization [:as_request_header_field_value]]
+ }
+
+ ProtocolParameters instproc as_entity_body {} {
+ :instvar {*}[:oauth_parameters]
+ set entity_body [export_vars [:oauth_parameters]]
+ #:msg $entity_body
+ return $entity_body
+ }
+
+ ProtocolParameters instproc as_request_header_field_value {} {
+ # http://tools.ietf.org/html/rfc5849#section-3.5.1
+ :instvar {*}[:oauth_parameters]
+ set formatted_pairs [list]
+ foreach p [:oauth_parameters] {
+ if {[info exists :$p]} {
+ set enc_p [::xo::oauth::utility urlencode $p]
+ set enc_pv [::xo::oauth::utility urlencode [my $p]]
+ lappend formatted_pairs "$enc_p=\"${enc_pv}\""
+ }
+ }
+ set header "OAuth "
+ append header [join $formatted_pairs ,]
+ return $header
+ }
+
+ # TODO: DRY
+ ProtocolParameters instproc get_parameter_list {} {
+ set params [list]
+ foreach p [:oauth_parameters] {
+ if {[info exists :$p]} {
+ lappend params $p [my $p]
+ }
+ }
+ return $params
+ }
+
+ ProtocolParameters instproc get_signature_parameter_list {} {
+ set params [list]
+ foreach p [:oauth_signature_parameters] {
+ if {[info exists :$p]} {
+ lappend params $p [my $p]
+ }
+ }
+ return $params
+ }
+ }
+}
+
+::xo::Module create ::xo::oauth::utility -eval {
+
+ if {[acs::icanuse "ns_urlencode -part oauth1"]} {
+ #
+ # Use oauth1 encoding for urlencode as provided by
+ # NaviServer. This version is not only a couple of magnitudes
+ # faster than the version below, it is as well required, when the
+ # coded strings have UTF-8 multibyte characters.
+ #
+ :proc urlencode {string} {
+ return [ns_urlencode -part oauth1 $string]
+ }
+
+ :proc urldecode {string} {
+ return [ns_urldecode -part oauth1 $string]
+ }
+
+ } else {
+
+ :proc urlencode {string} {
+ ###
+ ## Based on ::xowiki::urlencode, but using uppercase
+ ## hex codes and also excluding the ~ character, as
+ ## suggested by OAuth 1.0
+
+ set ue_map [list]
+ # We also need according decoding, as we do not want
+ # plusses to be replaced by spaces.
+ set ud_map [list]
+ for {set i 0} {$i < 128} {incr i} {
+ set c [format %c $i]
+ set x %[format %02X $i]
+ if {![string match {[-a-zA-Z0-9_~.]} $c]} {
+ lappend ue_map $c $x
+ lappend ud_map $x $c
+ }
+ }
+ for {set j 128} {$j < 256} {incr j} {
+ set c [format %c $j]
+ set x [ns_urlencode $c]
+ if {![string match {[-a-zA-Z0-9_~.]} $c]} {
+ set x [string toupper $x]
+ lappend ue_map $c $x
+ lappend ud_map $x $c
+ }
+ }
+ return [string map $ue_map $string]
+ }
+
+ :proc urldecode {string} {
+ #
+ # We also need according decoding, as we do not want
+ # plusses to be replaced by spaces.
+ #
+ set ud_map [list]
+ for {set i 0} {$i < 128} {incr i} {
+ set c [format %c $i]
+ set x %[format %02X $i]
+ if {![string match {[-a-zA-Z0-9_~.]} $c]} {
+ lappend ud_map $x $c
+ }
+ }
+
+ for {set j 128} {$j < 256} {incr j} {
+ set c [format %c $j]
+ set x [ns_urlencode $c]
+ if {![string match {[-a-zA-Z0-9_~.]} $c]} {
+ set x [string toupper $x]
+ lappend ud_map $x $c
+ }
+ }
+ return [string map $ud_map $string]
+ }
+ }
+}
+
+::xo::library source_dependent
+
+#
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 2
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/xooauth/tcl/oauth-server-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xooauth/tcl/Attic/oauth-server-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xooauth/tcl/oauth-server-procs.tcl 7 Nov 2020 17:58:25 -0000 1.1.2.1
@@ -0,0 +1,438 @@
+::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 {} {} {
+ 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 {} {
+ } {
+ 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 {} {
+ } {
+ # 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 ""} } {} {
+ # 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 ""}
+ } {
+ } {
+ 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 permissions system,
+ so that one is able to protect methods via policies. For example:
+
+ Class create Package -array set require_permission {
+ view {{id read}}
+ protected-service oauth
+ }
+
+ } {
+ #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
+ array set "" [uri::split $path_query_fragment]
+ set path $(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} {} {
+ # We cannot use urldecode, as this translates plusses to spaces.
+ #return [ns_urldecode $s]
+ 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:
Index: openacs-4/packages/xooauth/tcl/package-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xooauth/tcl/Attic/package-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xooauth/tcl/package-procs.tcl 7 Nov 2020 17:58:25 -0000 1.1.2.1
@@ -0,0 +1,126 @@
+::xo::library doc {
+ OAuth
+
+ @author Michael Aram
+ @creation-date 2012
+
+ Translation to XOTcl2:
+ Gustaf Neumann
+}
+
+::xo::library require oauth-server-procs
+
+namespace eval ::xo::oauth {
+
+ ::xo::PackageMgr create Package \
+ -superclass ::xo::Package \
+ -table_name "xooauth_packages" \
+ -pretty_name "OAuth" \
+ -package_key "xooauth" \
+ -parameter {
+ {folder_id 0}
+ } \
+ -instmixin {::xo::oauth::Server ::xo::oauth::Client}
+
+ Package instproc init {} {
+ next
+ set :folder_id [:require_root_folder \
+ -name "xooauth" \
+ -content_types {
+ ::xo::oauth::Credentials*
+ ::xo::oauth::ClientMetadata*
+ ::xo::oauth::ServerMetadata*
+ }]
+ ::xo::db::CrClass get_instance_from_db -item_id ${:folder_id}
+ set :delivery doc_return
+ #my log [:serialize]
+ }
+
+ Package instproc index {} {
+ set adp /packages/xooauth/lib/index
+ set :mime_type text/html
+ set package [self]
+ :return_page -adp $adp -variables {
+ package
+ }
+ }
+
+ Package proc reset {} {
+ # Convenience proc for development - delete all
+
+ # ::xo::db::Class doesn't CASCADE on drop
+ foreach object_type {
+ ::xo::oauth::TempCredentials
+ ::xo::oauth::TokenCredentials
+ ::xo::oauth::ClientCredentials
+ ::xo::oauth::Credentials
+ ::xo::oauth::ClientMetadata
+ ::xo::oauth::ServerMetadata
+ } {
+ set table_name [::xo::db::Class get_table_name -object_type $object_type]
+ #my msg "set table_name ::xo::db::Class get_table_name -object_type $object_type -> $table_name"
+ if { [catch {
+ xo::dc dml [:qn delete_instances] "delete from $table_name"
+ foreach ci [xo::dc list select_xoitems {
+ select item_id from cr_items where content_type = :object_type
+ }] {
+ content::item::delete -item_id $ci
+ }
+ xo::dc dml [:qn drop_table] "drop table $table_name cascade"
+ ::xo::db::sql::acs_object_type drop_type \
+ -object_type $object_type -cascade_p t
+ } fid] } {
+ :msg "Error during delete:\n$fid"
+ }
+ }
+ set p [::xo::oauth::Package initialize -url "/oauth"]
+ ::xo::clusterwide ns_cache flush xotcl_object_type_cache root_folder-[$p id]
+ ::content::folder::delete -folder_id [$p folder_id]
+
+ }
+ Package proc fill {} {
+ set p [::xo::oauth::Package initialize -url "/oauth"]
+ #$p require_server_metadata
+
+ # Create Server MD for the "remote" server
+ set sm [::xo::oauth::ServerMetadata new \
+ -parent_id [$p folder_id] \
+ -package_id [$p id] \
+ -temp_credentials_url "http://shell.itec.km.co.at/oauth/initiate" \
+ -token_credentials_url "http://shell.itec.km.co.at/oauth/token" \
+ -authorization_url "http://shell.itec.km.co.at/oauth/authorize"]
+ $sm save_new
+
+ # Create a dummy client metadata record
+ set cm [::xo::oauth::ClientMetadata new \
+ -parent_id [$p folder_id] \
+ -package_id [$p id] \
+ -title "An Example OAuth Consumer Application" \
+ -description "This is the description of the client application"]
+ $cm save_new
+
+ # Create a dummy client credentials record
+ set ccc [::xo::oauth::ClientCredentials new \
+ -parent_id [$p folder_id] \
+ -package_id [$p id] \
+ -identifier "client1" \
+ -secret "123" \
+ -client_metadata_id [$cm item_id] \
+ -server_metadata_id [[$p server_metadata] item_id]]
+ $ccc save_new
+
+ return [$sm serialize]
+
+ }
+
+
+}
+
+::xo::library source_dependent
+
+#
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 2
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/xooauth/tcl/test/xooauth-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xooauth/tcl/test/Attic/xooauth-test-procs.tcl,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xooauth/tcl/test/xooauth-test-procs.tcl 7 Nov 2020 17:58:25 -0000 1.1.2.1
@@ -0,0 +1 @@
+
Index: openacs-4/packages/xooauth/www/index.vuh
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xooauth/www/Attic/index.vuh,v
diff -u -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xooauth/www/index.vuh 7 Nov 2020 17:58:25 -0000 1.1.2.1
@@ -0,0 +1,24 @@
+# -*- Tcl -*-
+::xo::oauth::Package initialize -ad_doc {
+
+ This is the resolver for the OAuth package. It turns a request into
+ an object and executes the object with the computed method
+
+ @author Gustaf Neumann (gustaf.neumann@wu-wien.ac.at)
+ @creation-date July, 2006
+
+}
+
+regexp {[^/]*$} [ad_conn url] m
+
+if {$m eq ""} {
+ set m index
+}
+
+::$package_id log "--starting... [ns_conn url] [ns_conn query] \
+ form vars = [ns_set array [ns_getform]]"
+
+::$package_id reply_to_user [::$package_id $m]
+
+::$package_id log "--i ::$package_id DONE"
+ad_script_abort