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