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
[]
|