[22998] | 1 | #!/usr/bin/perl |
---|
| 2 | |
---|
| 3 | # Evolution wrapper script for Athena |
---|
| 4 | |
---|
| 5 | # Performs the following Evolution customizations: |
---|
| 6 | # * Ensures $HOME/.evolution is private when created. |
---|
| 7 | # * Performs Hesiod lookup of user inbox. |
---|
| 8 | # * Pre-configures Evolution for MIT mail on first invocation. |
---|
| 9 | |
---|
| 10 | use strict; |
---|
| 11 | use Gnome2::GConf; |
---|
[23955] | 12 | use File::Basename; |
---|
| 13 | use File::Path; |
---|
[22998] | 14 | |
---|
[23955] | 15 | sub edit_state_file(); |
---|
| 16 | sub create_initial_state_file(); |
---|
| 17 | |
---|
[22998] | 18 | # Ensure $HOME/.evolution is private when created. |
---|
| 19 | my $homedir = $ENV{"HOME"}; |
---|
| 20 | if ($homedir && ! -e "$homedir/.evolution") { |
---|
| 21 | if (mkdir("$homedir/.evolution")) { |
---|
| 22 | system("fs sa $homedir/.evolution system:anyuser none 2>/dev/null"); |
---|
| 23 | } |
---|
| 24 | } |
---|
| 25 | |
---|
| 26 | # Look up user inbox in Hesiod. |
---|
[23955] | 27 | my $user = $ENV{"ATHENA_USER"} || $ENV{"USER"} || getpwuid($<); |
---|
[22998] | 28 | my $result = `hesinfo $user pobox`; |
---|
| 29 | my @fields = split(' ', $result); |
---|
| 30 | my $server = $fields[1]; |
---|
| 31 | |
---|
[23955] | 32 | unless ($server) { |
---|
| 33 | warn "Could not obtain Hesiod POBOX information for $user\n"; |
---|
| 34 | exec("/usr/bin/evolution.debathena-orig", @ARGV); |
---|
| 35 | } |
---|
| 36 | |
---|
| 37 | # Determine the authentication method to use for the IMAP server. |
---|
| 38 | # For a Cyrus PO server account we use krb4, if the installed package |
---|
| 39 | # supports it. |
---|
| 40 | # For an Exchange account (or anything else), use password for now. |
---|
| 41 | # (Ideally some day we will use GSSAPI everywhere). |
---|
| 42 | my $auth = ""; |
---|
| 43 | if ($server =~ /po\d+\.mit\.edu/i) { |
---|
| 44 | my $provides = `dpkg-query -Wf '\${Provides}' 'libcamel*'`; |
---|
| 45 | if ($provides =~ /debathena-libcamel-krb4/) { |
---|
| 46 | $auth = ";auth=KERBEROS_V4"; |
---|
| 47 | } |
---|
| 48 | } |
---|
| 49 | |
---|
| 50 | # Regular expression for the server names we recognize when updating |
---|
| 51 | # the IMAP account setting. We also convert Athena 9.4-style Hesiod |
---|
| 52 | # specifications (although it should be unusual to see one due to |
---|
| 53 | # debathena-gconf2-config). |
---|
| 54 | my $serverRE = '(po\d+\.mit\.edu)|((imap\.)?exchange\.mit\.edu)|(_hesiod)'; |
---|
| 55 | my $old_server = ""; |
---|
| 56 | |
---|
[22998] | 57 | my $client = Gnome2::GConf::Client->get_default; |
---|
| 58 | my $accounts = $client->get_list("/apps/evolution/mail/accounts"); |
---|
| 59 | |
---|
[23955] | 60 | if ($accounts && @$accounts) { |
---|
| 61 | # Update the server with the value from Hesiod. |
---|
[22998] | 62 | my $change = 0; |
---|
| 63 | foreach (@$accounts) { |
---|
| 64 | my $old = $_; |
---|
| 65 | if (/name="MIT mail"/) { |
---|
[23955] | 66 | # Remember the old server name. |
---|
| 67 | if (m%imap://$user(?:;[^\@]*)?\@([^/]+)/%i) { |
---|
| 68 | $old_server = $1; |
---|
| 69 | } |
---|
| 70 | |
---|
| 71 | # Update the server name (and corresponding auth method). |
---|
| 72 | s%(imap://$user)(\;[^\@]*)?\@($serverRE)%$1$auth\@$server%i; |
---|
| 73 | |
---|
| 74 | # Make sure we always use SSL. |
---|
| 75 | unless (m%imap://[^/]*/[^<]*;use_ssl=always[^<]*%i) { |
---|
| 76 | # First clear any other SSL setting. |
---|
| 77 | s%(imap://[^/]*/[^<]*);use_ssl=[^;<]*([^<]*)%$1$2%i; |
---|
| 78 | s%(imap://[^/]*/)([^<]*)%$1;use_ssl=always$2%i; |
---|
| 79 | } |
---|
[22998] | 80 | } |
---|
| 81 | $change = 1 if ($_ ne $old); |
---|
| 82 | } |
---|
| 83 | |
---|
| 84 | if ($change) { |
---|
[23955] | 85 | # We need to update the account settings. |
---|
[22998] | 86 | $client->set_list("/apps/evolution/mail/accounts", "string", |
---|
| 87 | $accounts); |
---|
[23955] | 88 | if ($old_server ne $server) { |
---|
| 89 | # Edit the folder state file -- the URI of the saved |
---|
| 90 | # selected folder may point at the old server. |
---|
| 91 | edit_state_file(); |
---|
| 92 | } |
---|
[22998] | 93 | } |
---|
| 94 | } else { |
---|
| 95 | # Pre-configuration. |
---|
| 96 | $client->set_string("/apps/evolution/calendar/display/timezone", |
---|
| 97 | "America/New_York"); |
---|
[23092] | 98 | |
---|
[22998] | 99 | ($_, $_, $_, $_, $_, $_, my $gecos) = getpwuid($<); |
---|
| 100 | my @fields = split(",", $gecos); |
---|
| 101 | my $name = $fields[0]; |
---|
| 102 | my $home = $ENV{"HOME"}; |
---|
| 103 | my $local = "mbox:$home/.evolution/mail/local"; |
---|
| 104 | my $a = '<?xml version="1.0"?>' . "\n"; |
---|
| 105 | $a .= '<account name="MIT mail" uid="mitinitial" enabled="true">'; |
---|
| 106 | $a .= '<identity>'; |
---|
| 107 | $a .= "<name>$name</name>"; |
---|
| 108 | $a .= "<addr-spec>$user\@mit.edu</addr-spec>"; |
---|
| 109 | $a .= '</identity>'; |
---|
| 110 | $a .= '<source save-passwd="false">'; |
---|
[23955] | 111 | $a .= "<url>imap://$user$auth\@$server/;use_ssl=always</url>"; |
---|
[22998] | 112 | $a .= '</source>'; |
---|
| 113 | $a .= '<transport save-passwd="false">'; |
---|
| 114 | $a .= "<url>smtp://$user;auth=GSSAPI\@outgoing.mit.edu/;use_ssl=always"; |
---|
| 115 | $a .= '</url>'; |
---|
| 116 | $a .= '</transport>'; |
---|
| 117 | $a .= "<drafts-folder>$local#Drafts</drafts-folder>"; |
---|
| 118 | $a .= "<sent-folder>$local#Sent</sent-folder>"; |
---|
| 119 | $a .= '</account>' . "\n"; |
---|
| 120 | $accounts = [ $a ]; |
---|
| 121 | $client->set_list("/apps/evolution/mail/accounts", "string", $accounts); |
---|
| 122 | $client->set_string("/apps/evolution/mail/default_account", "mitinitial"); |
---|
[23955] | 123 | create_initial_state_file(); |
---|
[22998] | 124 | } |
---|
| 125 | |
---|
| 126 | exec("/usr/bin/evolution.debathena-orig", @ARGV); |
---|
[23955] | 127 | |
---|
| 128 | # Edit the existing folder tree state file, to update any URI referring to |
---|
| 129 | # the old server. |
---|
| 130 | sub edit_state_file() { |
---|
| 131 | return unless $old_server; |
---|
| 132 | my $file = "$homedir/.evolution/mail/config/folder-tree-expand-state.xml"; |
---|
| 133 | open(OLD, "<$file") or return; |
---|
| 134 | my $newfile = $file . ".debathena-new"; |
---|
| 135 | unless (open(NEW, ">$newfile")) { |
---|
| 136 | warn "Cannot open $newfile: $!\n"; |
---|
| 137 | close OLD; |
---|
| 138 | return; |
---|
| 139 | } |
---|
| 140 | my $changed = 0; |
---|
| 141 | # Loop to copy and edit the file, replacing the old IMAP server |
---|
| 142 | # name with the new. |
---|
| 143 | while (<OLD>) { |
---|
| 144 | my $old = $_; |
---|
| 145 | s%(imap://$user)(;[^\@]*)?\@($old_server)%$1\@$server%i; |
---|
| 146 | print NEW; |
---|
| 147 | $changed = 1 if ($_ ne $old); |
---|
| 148 | } |
---|
| 149 | close NEW; |
---|
| 150 | close OLD; |
---|
| 151 | # If we have changed the file, move the new one into place. |
---|
| 152 | # Otherwise, just delete the copy. |
---|
| 153 | if ($changed) { |
---|
| 154 | unless (rename($newfile, $file)) { |
---|
| 155 | warn "Cannot rename $newfile to $file: $!\n"; |
---|
| 156 | # Nuke the old file to be safe. |
---|
| 157 | unlink $file; |
---|
| 158 | } |
---|
| 159 | } else { |
---|
| 160 | unlink $newfile; |
---|
| 161 | } |
---|
| 162 | } |
---|
| 163 | |
---|
| 164 | # Create the initial folder tree state file, to expand and select the |
---|
| 165 | # MIT INBOX. |
---|
| 166 | sub create_initial_state_file() { |
---|
| 167 | my $file = "$homedir/.evolution/mail/config/folder-tree-expand-state.xml"; |
---|
| 168 | |
---|
| 169 | mkpath(dirname($file), 0, 0700); |
---|
| 170 | unless (open(OUT, ">$file")) { |
---|
| 171 | warn "Cannot open $file: $!\n"; |
---|
| 172 | return; |
---|
| 173 | } |
---|
| 174 | print OUT "<?xml version=\"1.0\"?>\n"; |
---|
| 175 | print OUT "<tree-state>\n"; |
---|
| 176 | print OUT " <node name=\"local\" expand=\"true\"/>\n"; |
---|
| 177 | print OUT " <node name=\"vfolder\" expand=\"false\"/>\n"; |
---|
| 178 | print OUT " <node name=\"mitinitial\" expand=\"true\">\n"; |
---|
| 179 | print OUT " <node name=\"INBOX\" expand=\"true\"/>\n"; |
---|
| 180 | print OUT " </node>\n"; |
---|
| 181 | print OUT " <selected uri=\"imap://$user\@$server/INBOX\"/>\n"; |
---|
| 182 | print OUT "</tree-state>\n"; |
---|
| 183 | close OUT; |
---|
| 184 | } |
---|