1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
(***********************************************************************)
(* mailsync.ml - Code for reading in and processing files received *)
(* from PKS-style email-based sync *)
(* *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(* 2011, 2012, 2013 Yaron Minsky and Contributors *)
(* *)
(* This file is part of SKS. SKS is free software; you can *)
(* redistribute it and/or modify it under the terms of the GNU General *)
(* Public License as published by the Free Software Foundation; either *)
(* version 2 of the License, or (at your option) any later version. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU General Public License *)
(* along with this program; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA or see <http://www.gnu.org/licenses/>. *)
(***********************************************************************)
open Common
open StdLabels
open MoreLabels
open Printf
let max_filesize = 200 * 1024
let input_msg f =
let b = Buffer.create (min max_filesize (in_channel_length f)) in
Buffer.add_channel b f (in_channel_length f);
Buffer.contents b
let dirname = "messages"
let lsdir dir =
let dirhandle = Unix.opendir dir in
let run () =
let rec loop accum =
match (try Some (Unix.readdir dirhandle)
with End_of_file -> None)
with
Some fname -> loop (fname::accum)
| None -> accum
in
List.map ~f:(Filename.concat dir) (loop [])
in
protect ~f:run ~finally:(fun () -> Unix.closedir dirhandle)
(** reads specified mail file and returns key if any *)
let load_message fname =
let file = open_in fname in
let run () =
let text = input_msg file in
(*let msg = Recvmail.parse text in
msg.Sendmail.body *)
text
in
protect ~f:run ~finally:(fun () -> close_in file)
let get_mtime fname = (Unix.stat fname).Unix.st_mtime
let demote fname =
if Sys.file_exists fname then
let destdir = Lazy.force Settings.failed_msgdir in
if not (Sys.file_exists destdir) then
Unix.mkdir destdir 0o700;
Sys.rename fname (Filename.concat destdir (Filename.basename fname))
(****************************************************************************)
(* Event Handlers **********************************************************)
(****************************************************************************)
(** read any mails in queue directory, process them, and remove them *)
let rec load_mailed_keys ~addkey () =
if !Settings.send_mailsyncs then
(
plerror 7 "checking for key emails";
let files = try lsdir (Lazy.force Settings.msgdir) with Unix.Unix_error _ -> [] in
let ready_files =
List.filter ~f:(fun file -> Filename.check_suffix file ".ready") files
in
List.iter ready_files
~f:(fun fname ->
try
let text = load_message fname in
let keys = Armor.decode_pubkey text in
plerror 3 "Adding list of %d keys from file %s"
(List.length keys) fname;
List.iter
~f:(fun origkey ->
try
let key = Fixkey.canonicalize origkey in
addkey key
with
Bdb.Key_exists -> ()
| Fixkey.Bad_key ->
plerror 2 "Fixkey.canonicalize couldn't parse key %s"
(KeyHash.hexify (KeyHash.hash origkey))
)
keys;
Sys.remove fname
with
| Eventloop.SigAlarm | Sys.Break as e -> raise e
| e ->
eplerror 2 e "Failure adding keys from file %s. %s"
fname "Moving to failed_messages.";
demote fname
);
[]
)
else
[]
|
