tkgoodstuff/tcl/BiffIMAP.tcl

296 lines
7.8 KiB
Tcl
Raw Permalink Normal View History

#Biff "IMAP" method: look for "Unseen" messages on IMAP server
proc BiffIMAPInit {} {
}
proc BiffIMAPDeclare {f} {
TKGDeclare Biff($f,host) "" \
-typelist [list Clients Biff Mailboxes [TKGDecode $f] IMAP] \
-label "Hostname of IMAP server"
TKGDeclare Biff($f,port) 143 \
-typelist [list Clients Biff Mailboxes [TKGDecode $f] IMAP] \
-label "IMAP port number on server"
TKGDeclare Biff($f,user) "" -fallback [exec whoami] \
-typelist [list Clients Biff Mailboxes [TKGDecode $f] IMAP] \
-label "Username on IMAP server"
TKGDeclare Biff($f,password) "" \
-typelist [list Clients Biff Mailboxes [TKGDecode $f] IMAP] \
-label "Password" \
-help "If password is left empty, you will be asked for it at
tkgoodstuff startup."
TKGDeclare Biff($f,useNet) 1 \
-typelist [list Clients Biff Mailboxes [TKGDecode $f] IMAP] \
-vartype boolean \
-label "Rely on Net client, if used" \
-help "When enabled, if the tkgoodstuff Net client is used we will
check for mail on the IMAP server only when the net is up."
}
proc BiffIMAPFolderInit {f} {
global Biff
set Biff($f,unseen) ""
set Biff($f,all) ""
BiffIMAPSetBusy $f 0
}
proc BiffIMAPStart {f} {
global Biff TKG Net
lappend mapcmd TKGPeriodic BiffUpdate$f \
$Biff($f,update_interval) $Biff($f,update_interval) {BiffUpdate $f}
if {([lsearch $TKG(clients) Net] != -1) && $Biff($f,useNet)} {
TKGAddToHook Net_up_hook $mapcmd "BiffUpdate $f"
TKGAddToHook Net_down_hook \
"TKGPeriodicCancel BiffUpdate$f"
if !!$Net(linkstatus) {BiffUpdate $f}
} else {
eval $mapcmd
BiffUpdate $f
}
}
# Check if there is new "Unseen" mail, and fetch the
# header data (frmlist) if there are changes in the lists
# of unseen messages.
proc BiffIMAPTest {f} {
global Biff
if [BiffIMAPBusy $f] {
return nochange
}
BiffIMAPSetBusy $f 1
if ![BiffIMAPEnsure $f] {
BiffIMAPSetBusy $f 0
return nochange
}
set oldunseen $Biff($f,unseen)
BiffIMAPCheck $f
BiffIMAPSetBusy $f 0
if {(![string match $oldunseen $Biff($f,unseen)])
|| ![info exists Biff($f,frmlist)]} {
set Biff($f,frmlist) [BiffIMAPGetFrmList $f 0]
}
if {[string match $oldunseen $Biff($f,unseen)]} {
set ret nochange
} else {
set ret 0
foreach unseen $Biff($f,unseen) {
if {![In $unseen $oldunseen]} {
set ret 1
}
}
}
return $ret
}
proc BiffIMAPCheck {f} {
global Biff TKGExpect
set id $Biff($f,id)
if ![TKGExpect $Biff($f,id) \
"Check1 check" "{Check1 OK }"] return
if [TKGExpect $id \
"Check2 search unseen" "{\\* SEARCH(.*)\n.*Check2 OK }"] {
set Biff($f,unseen) $TKGExpect($id,submatch1)
}
if $Biff(count) {
BiffCountLabel $f [llength $Biff($f,unseen)]
}
}
proc BiffIMAPIgnore {f} {
}
# Because it may take too long, if possible don't fetch a new frmlist.
proc BiffIMAPScan {f} {
global Biff
if {![info exists Biff($f,frmlist)]
|| [string match error [lindex $Biff($f,frmlist) 0]]} {
set Biff($f,frmlist) [BiffIMAPGetFrmList $f]
}
return $Biff($f,frmlist)
}
proc BiffIMAPGetFrmList {f {docheck 1}} {
global Biff TKGExpect
if [BiffIMAPBusy $f] {
return "error {IMAP connection busy. Try again later.}"
}
BiffIMAPSetBusy $f 1
if ![BiffIMAPEnsure $f] {
BiffIMAPSetBusy $f 0
return "error {Could not log into IMAP server. Try again later.}"
}
set id $Biff($f,id)
if $docheck {BiffIMAPCheck $f}
set error 0
set frmlist ""
set Biff($f,all) ""
if [TKGExpect $id \
"Scan1 search all" "{\\* SEARCH(.*)\n.*Scan1 OK }"] {
set Biff($f,all) $TKGExpect($id,submatch1)
} else {
set error 1
}
if $Biff($f,listall) {
set msgs all
} else {
set msgs unseen
}
foreach mnum $Biff($f,$msgs) {
if ![TKGExpect $id \
"f$mnum fetch $mnum envelope" \
"{\\* $mnum FETCH \\(ENVELOPE (.*)\\)\nf$mnum OK } \
{\\* $mnum FETCH \\(ENVELOPE (.*)\\)\n\\* $mnum FETCH}"] {
set error 1
break
}
regsub -all \n $TKGExpect($id,submatch1) \r\n E
set E [TKGSexpr $E]
set addr [lindex [lindex $E 2] 0]
if ![string match NIL [lindex $addr 0]] {
set From [lindex $addr 0]
} else {
set From "[lindex $addr 2]@[lindex $addr 3]"
}
set Subj [lindex $E 1]
set New [In $mnum $Biff($f,unseen)]
lappend frmlist [list $From $Subj $New $mnum]
}
if $error {
set frmlist "error {Error fetching list of messages from IMAP server.}"
}
BiffIMAPSetBusy $f 0
return $frmlist
}
proc BiffIMAPGetMessage {f mnum} {
global Biff TKGExpect
if [BiffIMAPBusy $f] {
return "error {IMAP connection busy. Try again later.}"
}
BiffIMAPSetBusy $f 1
if ![BiffIMAPEnsure $f] {
BiffIMAPSetBusy $f 0
return "error {Could not log into IMAP server. Try again later.}"
}
set id $Biff($f,id)
if ![TKGExpect $id "g$mnum fetch $mnum rfc822" "{\\* $mnum FETCH \\(RFC822 {(\[0-9\]*)}\n(.*)\ng$mnum OK}"] {
set result "error {Error fetching message from IMAP server.}"
} else {
regsub -all "\n" $TKGExpect($id,submatch2) "\n\n" result
set result [string range $result 0 \
[expr $TKGExpect($id,submatch1) - 1]]
regsub -all "\n\n" $result "\n" result
}
BiffIMAPSetBusy $f 0
return $result
}
proc BiffIMAPLogin {f} {
global Biff TKGExpect
foreach v {host port user password} {
set $v $Biff($f,$v)
}
while 1 {
if [string match $password @@ABORT@@] {return 0}
if {![info exists Biff($f,id)]} {
if [catch {
set Biff($f,id) [socket -async $host $port]
}] {
return 0
}
fconfigure $Biff($f,id) -buffering none -blocking 0
if ![TKGExpect $Biff($f,id) "" {{\* OK }}] {return 0}
}
if ![Empty $password] {
if ![TKGExpect $Biff($f,id) \
"Login1 login $user $password" \
"{\\* BYE .*\n|Login1 OK|Login1 NO .*\n|Login1 BAD .*\n}"] {return 0}
set match $TKGExpect($Biff($f,id),match)
if [regexp "\\* BYE (\[^\n\]*)\n.*" $match err err] {
set Biff($f,password) @@ABORT@@
TKGNotice "Aborting IMAP login of $user to $host failed:\n\n $err"
return 0
} elseif {[regexp "Login1 NO (\[^\n\]*)\n.*" $match err err]
|| [regexp "Login1 BAD (\[^\n\]*)\n.*" $match err err]} {
set err "Login of $user on $host failed:\n\n $err\n\nTry again?\n\n"
} else break
} else {
set err ""
}
set password [TKGGetPassword "IMAP Password for [TKGDecode $f]" $err]
set Biff($f,password) $password
}
if ![TKGExpect $Biff($f,id) \
"Login2 select $Biff($f,folder)" \
"{Login2 OK } {Login2 NO .*\n}"] {return 0}
if [regexp "Login2 NO (\[^\n\]*)\n.*" $TKGExpect($Biff($f,id),match) err err] {
set Biff($f,password) @@ABORT**
TKGNotice "Aborting IMAP checking for $f:\n\n $err"
return 0
}
return 1
}
proc BiffIMAPLogout {f} {
global Biff
if {![catch {fconfigure $Biff($f,id)}]} {
TKGExpect $Biff($f,id) "666 logout" {{\* BYE .*$}}
}
BiffIMAPClose $f
}
proc BiffIMAPClose {f} {
global Biff
catch {close $Biff($f,id)}
catch {
unset Biff($f,id)
}
}
proc BiffIMAPEnsure {f} {
global Biff
set count 3
if [string match $Biff($f,password) @@ABORT@@] {
return 0
}
while {![BiffIMAPConnected $f]} {
BiffIMAPClose $f
BiffIMAPLogin $f
incr count -1
if !$count {
BiffIMAPClose $f
break
}
if [string match $Biff($f,password) @@ABORT@@] {
return 0
}
}
return !!$count
}
proc BiffIMAPBusy {f} {
global Biff
set wait 15
set i 0
while {[info exists [set v Biff(busywait$i)]]} {incr i}
while {[BiffIMAPSetBusy $f] && $wait} {
after 1000 set $v 1
vwait $v
incr wait -1
}
catch {unset $v}
return [BiffIMAPSetBusy $f]
}
proc BiffIMAPSetBusy {f {busy {}}} {
global Biff
eval set Biff(busy,$Biff($f,host),$Biff($f,user)) $busy
}
proc BiffIMAPConnected {f} {
global Biff
if {![info exists Biff($f,id)]} {return 0}
return [TKGExpect $Biff($f,id) "cnct noop" "{cnct OK.*$}" 10000]
}