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; |
---|
12 | use File::Basename; |
---|
13 | use File::Path; |
---|
14 | |
---|
15 | sub edit_state_file(); |
---|
16 | sub create_initial_state_file(); |
---|
17 | |
---|
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. |
---|
27 | my $user = $ENV{"ATHENA_USER"} || $ENV{"USER"} || getpwuid($<); |
---|
28 | my $result = `hesinfo $user pobox`; |
---|
29 | my @fields = split(' ', $result); |
---|
30 | my $server = $fields[1]; |
---|
31 | |
---|
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 | |
---|
57 | my $client = Gnome2::GConf::Client->get_default; |
---|
58 | my $accounts = $client->get_list("/apps/evolution/mail/accounts"); |
---|
59 | |
---|
60 | if ($accounts && @$accounts) { |
---|
61 | # Update the server with the value from Hesiod. |
---|
62 | my $change = 0; |
---|
63 | foreach (@$accounts) { |
---|
64 | my $old = $_; |
---|
65 | if (/name="MIT mail"/) { |
---|
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 | } |
---|
80 | } |
---|
81 | $change = 1 if ($_ ne $old); |
---|
82 | } |
---|
83 | |
---|
84 | if ($change) { |
---|
85 | # We need to update the account settings. |
---|
86 | $client->set_list("/apps/evolution/mail/accounts", "string", |
---|
87 | $accounts); |
---|
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 | } |
---|
93 | } |
---|
94 | } else { |
---|
95 | # Pre-configuration. |
---|
96 | $client->set_string("/apps/evolution/calendar/display/timezone", |
---|
97 | "America/New_York"); |
---|
98 | |
---|
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">'; |
---|
111 | $a .= "<url>imap://$user$auth\@$server/;use_ssl=always</url>"; |
---|
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"); |
---|
123 | create_initial_state_file(); |
---|
124 | } |
---|
125 | |
---|
126 | exec("/usr/bin/evolution.debathena-orig", @ARGV); |
---|
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 | } |
---|