1# OOB.tcl --- 2# 3# This file is part of The Coccinella application. 4# It implements the UI of the jabber:iq:oob part of the jabber. 5# 6# Copyright (c) 2001-2005 Mats Bengtsson 7# 8# This program is free software: you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation, either version 3 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program. If not, see <http://www.gnu.org/licenses/>. 20# 21# $Id: OOB.tcl,v 1.65 2008-06-09 09:51:00 matben Exp $ 22 23# NOTE: Parts if this code is obsolete (the send part) but the receiving 24# part is still retained for backwards compatibility. 25 26package require uriencode 27 28package provide OOB 1.0 29 30namespace eval ::OOB { 31 32 ::hooks::register jabberInitHook ::OOB::InitJabberHook 33 34 # Running number for token. 35 variable uid 0 36 37} 38 39proc ::OOB::InitJabberHook {jlibname} { 40 41 # Be sure to handle incoming requestes (iq set elements). 42 ::Jabber::Jlib iq_register set jabber:iq:oob ::OOB::ParseSet 43} 44 45# OOB::ParseSet -- 46# 47# Gets called when we get a 'jabber:iq:oob' 'set' element, that is, 48# another user sends us an url to fetch a file from. 49 50proc ::OOB::ParseSet {jlibname from subiq args} { 51 global prefs 52 variable locals 53 54 eval {::hooks::run oobSetRequestHook $from $subiq} $args 55 56 array set argsA $args 57 58 # Be sure to trace any 'id' attribute for confirmation. 59 if {[info exists argsA(-id)]} { 60 set id $argsA(-id) 61 } else { 62 return 0 63 } 64 foreach child [wrapper::getchildren $subiq] { 65 set tag [wrapper::gettag $child] 66 set $tag [wrapper::getcdata $child] 67 } 68 if {![info exists url]} { 69 #::UI::MessageBox -title [mc "Error"] -icon error -type ok \ 70 # -message [mc "%s did not sent the download location of the file." $from] 71 return 0 72 } 73 74 # Validate URL, determine the server host and port. 75 if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ 76 x prefix proto host y port path]} { 77 #::UI::MessageBox -title [mc "Error"] -icon error -type ok \ 78 # -message [mc "Received invalid URL from %s. URL: %s" $from $url] 79 return 0 80 } 81 if {[string length $proto] == 0} { 82 set proto http 83 } 84 if {$proto ne "http"} { 85 #::UI::MessageBox -title [mc "Error"] -icon error -type ok \ 86 # -message [mc "The URL from %s does not use the HTTP protocol, but instead %s which is not supported." $from $proto] 87 return 0 88 } 89 set tail [file tail $url] 90 set tailDec [::uri::urn::unquote $tail] 91 92 set str [mc "File"] 93 append str ": $tailDec" 94 if {[info exists desc]} { 95 append str "\n" 96 append str [mc "Description"] 97 append str ": $desc" 98 } 99 100 set w [ui::autoname] 101 102 # Keep instance specific state array. 103 variable $w 104 upvar 0 $w state 105 106 set state(w) $w 107 set state(id) $id 108 set state(url) $url 109 set state(from) $from 110 set state(queryE) $subiq 111 set state(args) $args 112 113 set msg [mc "%s wants to send you this file: %s Do you want to receive this file?" $from $str] 114 ui::dialog $w -title [mc "Receive File"] -icon info \ 115 -type yesno -default yes -message $msg \ 116 -command [namespace code ParseSetCmd] 117 118 return 1 119} 120 121proc ::OOB::ParseSetCmd {w bt} { 122 global prefs 123 variable $w 124 upvar 0 $w state 125 126 if {$bt eq "no"} { 127 ReturnError $state(from) $state(id) $state(queryE) 406 128 } else { 129 set url $state(url) 130 set tail [file tail $url] 131 set tailDec [::uri::urn::unquote $tail] 132 set userDir [::Utils::GetDirIfExist $prefs(userPath)] 133 set localPath [tk_getSaveFile -title [mc "Save File"] \ 134 -initialfile $tailDec -initialdir $userDir] 135 if {$localPath eq ""} { 136 ReturnError $state(from) $state(id) $state(queryE) 406 137 } else { 138 set prefs(userPath) [file dirname $localPath] 139 140 # And get it. 141 Get $state(from) $url $localPath $state(id) $state(queryE) 142 } 143 } 144 unset -nocomplain state 145} 146 147proc ::OOB::Get {jid url file id subiq} { 148 149 set token [::HttpTrpt::Get $url $file -command \ 150 [list ::OOB::HttpCmd $jid $id $subiq]] 151} 152 153proc ::OOB::HttpCmd {jid id subiq token status {errmsg ""}} { 154 variable $token 155 upvar 0 $token state 156 157 ::Debug 2 "::OOB::HttpCmd status=$status, errmsg=$errmsg" 158 159 # We shall send an <iq result> element here using the same 'id' to notify 160 # the sender we are done. 161 162 switch -- $status { 163 ok { 164 ::Jabber::Jlib send_iq "result" {} -to $jid -id $id 165 } 166 reset { 167 ReturnError $jid $id $subiq 406 168 } 169 default { 170 set httptoken $state(httptoken) 171 set ncode [::httpex::ncode $httptoken] 172 ReturnError $jid $id $subiq $ncode 173 } 174 } 175} 176 177proc ::OOB::ReturnError {jid id subiq ncode} { 178 179 switch -- $ncode { 180 406 { 181 set type modify 182 set tag "not-acceptable" 183 } 184 default { 185 set type cancel 186 set tag "not-found" 187 } 188 } 189 190 set subElem [wrapper::createtag $tag -attrlist \ 191 [list xmlns "urn:ietf:params:xml:ns:xmpp-stanzas"]] 192 set errElem [wrapper::createtag "error" -attrlist \ 193 [list code $ncode type $type] -subtags [list $subElem]] 194 195 ::Jabber::Jlib send_iq "error" [list $subiq $errElem] -to $jid -id $id 196} 197 198# OOB::BuildText -- 199# 200# Make a clickable text widget from a <x xmlns='jabber:x:oob'> element. 201# 202# Arguments: 203# w widget to create 204# xml a xml list element <x xmlns='jabber:x:oob'> 205# args -width 206# 207# Results: 208# w 209 210proc ::OOB::BuildText {w xml args} { 211 global prefs 212 213 if {[wrapper::gettag $xml] != "x"} { 214 error {Not proper xml data here} 215 } 216 array set attr [wrapper::getattrlist $xml] 217 if {![info exists attr(xmlns)]} { 218 error {Not proper xml data here} 219 } 220 if {![string equal $attr(xmlns) "jabber:x:oob"]} { 221 error {Not proper xml data here} 222 } 223 array set argsA { 224 -width 30 225 } 226 array set argsA $args 227 set nlines 1 228 foreach c [wrapper::getchildren $xml] { 229 switch -- [wrapper::gettag $c] { 230 desc { 231 set desc [wrapper::getcdata $c] 232 set nlines [expr {[string length $desc]/$argsA(-width) + 1}] 233 } 234 url { 235 set url [wrapper::getcdata $c] 236 } 237 } 238 } 239 240 set bg [option get . backgroundGeneral {}] 241 242 text $w -bd 0 -wrap word -width $argsA(-width) \ 243 -background $bg -height $nlines \ 244 -highlightthickness 0 245 if {[info exists desc] && [info exists url]} { 246 ::Text::InsertURL $w $desc $url {} 247 } 248 return $w 249} 250 251#------------------------------------------------------------------------------- 252