-- Topal: GPG/GnuPG and Alpine/Pine integration -- Copyright (C) 2001--2012 Phillip J. Brooke -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License version 3 as -- published by the Free Software Foundation. -- -- 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, see . with Ada.Characters.Latin_1; with Ada.IO_Exceptions; with Ada.Numerics.Discrete_Random; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Ada.Strings.Unbounded; with Ada.Text_IO; with Externals.Mail; with Externals.Simple; with Menus; use Menus; with Misc; use Misc; package body Externals.Mail is -- We need to figure out what the boundary is. We don't trust Pine -- and the shell to get it for us, so we'll use this heuristic. -- Open Infile, read it in a line at a time. If a line has the -- form `--(some characters)--' then save it. The *last* one is -- assumed to be the correct boundary. Then we just have to slice -- off the leading and trailiing `--'. function Find_Mime_Boundary (Infile : String) return UBS is BF : Ada.Text_IO.File_Type; L2 : UBS; -- the line we've read in. PB : UBS; -- possible boundary begin Debug("+Externals.Mail.Find_Mime_Boundary"); Ada.Text_IO.Open(File => BF, Mode => Ada.Text_IO.In_File, Name => Infile); Boundary_Loop: loop begin L2 := Unbounded_Get_Line(BF); declare L2S : constant String := ToStr(L2); begin Debug("Considering: " & L2S); if L2S'Length > 4 then if L2S(1..2) = "--" and L2S(L2S'Last-1..L2S'Last) = "--" then -- This is a possible boundary. PB := ToUBS(L2S(3..L2S'Last-2)); Debug("Possible boundary: " & ToStr(PB)); end if; end if; end; exception when Ada.IO_Exceptions.End_Error => exit Boundary_Loop; -- Ignore. end; end loop Boundary_Loop; Ada.Text_IO.Close(BF); Debug("-Externals.Mail.Find_Mime_Boundary"); return PB; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Find_Mime_Boundary"); raise; end Find_Mime_Boundary; -- I should really generalise this to n part MIME.... procedure Split_Two_Parts (Infile : in String; Part_One : in String; Part_Two : in String; Boundary : in UBS) is Infile_F : Ada.Text_IO.File_Type; Part_One_F : Character_IO.File_Type; Part_Two_F : Character_IO.File_Type; L1 : UBS; L2 : UBS; BS : constant String := ToStr(Boundary); begin -- Open files.... begin Ada.Text_IO.Open(File => Infile_F, Mode => Ada.Text_IO.In_File, Name => Infile); Character_IO.Create(File => Part_One_F, Mode => Character_IO.Out_File, Name => Part_One); Character_IO.Create(File => Part_Two_F, Mode => Character_IO.Out_File, Name => Part_Two); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Split_Two_Parts (Opening files)"); raise; end; -- Get the two parts. The first part, we want to include the MIME -- headers, but not the boundaries nor the blank line before the next -- part. -- So, first, we walk through infile looking for the boundary. begin Find_First_Boundary: loop L2 := Unbounded_Get_Line(Infile_F); declare L2S : constant String := ToStr(L2); begin exit Find_First_Boundary when L2S = "--" & BS; end; end loop Find_First_Boundary; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Split_Two_Parts (Find_First_Boundary)"); raise; end; -- Now, walk through infile, copying complete lines to Part_One -- until we find a blank line - boundary pair. begin L1 := Unbounded_Get_Line(Infile_F); Find_Second_Boundary: loop L2 := Unbounded_Get_Line(Infile_F); declare L1S : constant String := ToStr(L1); L2S : constant String := ToStr(L2); begin exit Find_Second_Boundary when L1S'Length = 0 and L2S = "--" & BS; -- Trap case where data ends without newline. if L2S = "--" & BS then Character_IO_Put(Part_One_F, L1S); exit Find_Second_Boundary; end if; Character_IO_Put_Line(Part_One_F, L1S); end; L1 := L2; end loop Find_Second_Boundary; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Split_Two_Parts (Find_Second_Boundary)"); raise; end; -- Continue through infile, copying complete lines to Part_Two, -- until we find another blank_line - boundary pair. begin L1 := Unbounded_Get_Line(Infile_F); Find_Third_Boundary: loop L2 := Unbounded_Get_Line(Infile_F); declare L1S : constant String := ToStr(L1); L2S : constant String := ToStr(L2); begin exit Find_Third_Boundary when L1S'Length = 0 and L2S = "--" & BS & "--"; -- Trap case where data ends without newline. if L2S = "--" & BS & "--" then Character_IO_Put(Part_Two_F, L1S); exit Find_Third_Boundary; end if; Character_IO_Put_Line(Part_Two_F, L1S); end; L1 := L2; end loop Find_Third_Boundary; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Split_Two_Parts (Find_Third_Boundary)"); raise; end; -- Close files. begin Ada.Text_IO.Close(Infile_F); Character_IO.Close(Part_One_F); Character_IO.Close(Part_Two_F); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Split_Two_Parts (Closing files)"); raise; end; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Split_Two_Parts"); raise; end Split_Two_Parts; procedure Get_First_Part (-- Input file. Infile : in String; -- Outputs: -- 1. Prolog (file). Prolog : in String; -- 2. Boundary detected (including leading --). Boundary : out UBS; -- 3. Part header (file). Part_Hdr : in String; -- 4. Part body (file). Neither 3 nor 4 includes the blank line separator. Part_Body : in String; -- 5. Rest of file (including boundary between 4 and this) (file). Remainder : in String ) is -- We're expecting a file from DTBL output. -- This is the body of a Pine multipart/mixed. -- We can get the first boundary line by searching for the first -- prefixed line. Infile_F : Ada.Text_IO.File_Type; Out_F1 : Character_IO.File_Type; Out_F3 : Character_IO.File_Type; Out_F4 : Character_IO.File_Type; Out_F5 : Character_IO.File_Type; L : UBS; begin -- Open files.... begin Ada.Text_IO.Open(File => Infile_F, Mode => Ada.Text_IO.In_File, Name => Infile); Character_IO.Create(File => Out_F1, Mode => Character_IO.Out_File, Name => Prolog); Character_IO.Create(File => Out_F3, Mode => Character_IO.Out_File, Name => Part_Hdr); Character_IO.Create(File => Out_F4, Mode => Character_IO.Out_File, Name => Part_Body); Character_IO.Create(File => Out_F5, Mode => Character_IO.Out_File, Name => Remainder); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Get_First_Part (Opening files)"); raise; end; Find_Boundary: loop L := Unbounded_Get_Line(Infile_F); declare L2 : constant String := ToStr(L); begin if L2'Length > 2 and then L2(1..2) = "--" then Boundary := L; exit Find_Boundary; end if; -- Otherwise, it's part of the prolog. Character_IO_Put_Line(Out_F1, ToStr(L)); end; end loop Find_Boundary; -- Write out the boundary we just read to the end of the prolog. Character_IO_Put_Line(Out_F1, ToStr(L)); Character_IO.Close(Out_F1); -- We've now got the boundary. Find a blank line. Find_Blank_Line: loop L := Unbounded_Get_Line(Infile_F); declare L2 : constant String := ToStr(L); begin exit when L2'Length = 0; -- Otherwise, it's part of the part header. Character_IO_Put_Line(Out_F3, ToStr(L)); end; end loop Find_Blank_Line; Character_IO.Close(Out_F3); -- Now we've got a blank line. Everything up to the next -- boundary is the part body. Find_Next_Boundary: loop L := Unbounded_Get_Line(Infile_F); declare L2 : constant String := ToStr(L); begin exit when L2 = ToStr(Boundary); -- Otherwise, it's part of the part header. Character_IO_Put_Line(Out_F4, ToStr(L)); end; end loop Find_Next_Boundary; Character_IO.Close(Out_F4); -- Write out the boundary we just read, and then the rest of the file. Character_IO_Put_Line(Out_F5, ToStr(L)); Eat_Remainder: loop exit when Ada.Text_IO.End_Of_File(Infile_F); L := Unbounded_Get_Line(Infile_F); Character_IO_Put_Line(Out_F5, ToStr(L)); end loop Eat_Remainder; -- Done, close the last files. Character_IO.Close(Out_F5); Ada.Text_IO.Close(Infile_F); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Get_First_Part"); raise; end Get_First_Part; procedure Extract_Content_Type_From_Header (Email_Filename : in String; Target_Filename : in String; Ignore_Missing : in Boolean := False; Substitute : in Boolean := False) is E1, E2 : Integer; begin ForkExec2_InOut(Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("1,/^[:space:]*$/ ! d")), E1, Value_Nonempty(Config.Binary(Grep)), UBS_Array'(0 => ToUBS("grep"), 1 => ToUBS("-i"), 2 => ToUBS("content-type: ")), E2, Source => Email_Filename, Target => Target_Filename); if E1 /= 0 then Error("Problem with sed! (ff2a)"); elsif E2 /= 0 and (not Ignore_Missing) then Error("Problem with grep! (ff2b)"); end if; if E2 /= 0 and Substitute then -- Write the default into Target_Filename. Externals.Simple.Echo_Out("Content-Type: Text/Plain; Charset=US-ASCII", Target_Filename); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Extract_Content_Type_From_Header (Email_Filename=" & Email_Filename & ", Target_Filename=" & Target_Filename & ")"); raise; end Extract_Content_Type_From_Header; procedure Extract_Content_Transfer_Encoding_From_Header (Email_Filename : in String; Target_Filename : in String; Ignore_Missing : in Boolean := False; Substitute : in Boolean := False) is E1, E2 : Integer; begin ForkExec2_InOut(Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("1,/^[:space:]*$/ ! d")), E1, Value_Nonempty(Config.Binary(Grep)), UBS_Array'(0 => ToUBS("grep"), 1 => ToUBS("-i"), 2 => ToUBS("content-transfer-encoding: ")), E2, Source => Email_Filename, Target => Target_Filename); if E1 /= 0 then Error("Problem with sed! (ff2aa)"); elsif E2 /= 0 and (not Ignore_Missing) then Error("Problem with grep! (ff2ba)"); end if; if E2 /= 0 and Substitute then -- Write the default into Target_Filename. Externals.Simple.Echo_Out("Content-Transfer-Encoding: 7BIT", Target_Filename); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Extract_Content_Transfer_Encoding_From_Header"); raise; end Extract_Content_Transfer_Encoding_From_Header; -- Get the header from a header-body mail into a file. procedure Extract_Header (Email_Filename : in String; Target_Filename : in String) is begin if ForkExec_InOut(Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("-e"), 2 => ToUBS("1,/^[:space:]*$/ ! d"), 3 => ToUBS("-e"), 4 => ToUBS("/^[:space:]*$/ d")), Source => Email_Filename, Target => Target_Filename) /= 0 then Error("sed failed! (ff11)"); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Extract_Header"); raise; end Extract_Header; -- Get the body from a header-body mail into a file. procedure Extract_Body (Email_Filename : in String; Target_Filename : in String) is E1, E2 : Integer; begin ForkExec2_InOut(Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("-e"), 2 => ToUBS("/^[:space:]*$/,$ ! d")), E1, Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("-e"), 2 => ToUBS("1,1 { /^[:space:]*$/ d ; }")), E2, Source => Email_Filename, Target => Target_Filename); if E1 /= 0 then Error("sed failed! (ff3)"); elsif E2 /= 0 then Error("sed failed! (ff13)"); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Extract_Body"); raise; end Extract_Body; procedure Delete_Trailing_Blank_Lines (Infile : in String; Outfile : in String) is begin if ForkExec_InOut(Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("-e"), 2 => ToUBS(":a"), 3 => ToUBS("-e"), 4 => ToUBS("/^\n*$/{$d;N;};/\n$/ba")), Source => Infile, Target => Outfile) /= 0 then Error("sed failed! (ff5)"); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Delete_Trailing_Blank_Lines"); raise; end Delete_Trailing_Blank_Lines; -- A temporary file that we'll re-use for cleaning email addresses. Clean_Email_Tempfile : UBS; procedure Clean_Email_Address (F : in String) is use Ada.Strings.Unbounded; E1, E2 : Integer; begin if Clean_Email_Tempfile = Null_Unbounded_String then Clean_Email_Tempfile := ToUBS(Temp_File_Name("cleane")); end if; ForkExec2_InOut(Misc.Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("s/""[^""]*""//g; s/,/\n/g")), E1, Misc.Value_Nonempty(Config.Binary(Sed)), UBS_Array'(0 => ToUBS("sed"), 1 => ToUBS("s/^.*.*$//; s/ *//g; s/,/\n/g")), E2, F, ToStr(Clean_Email_Tempfile)); Externals.Simple.Mv_F(ToStr(Clean_Email_Tempfile), F); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Clean_Email_address (procedure)"); raise; end Clean_Email_Address; function Clean_Email_Address (E : in String) return String is L, R : Natural; use Ada.Strings.Fixed; begin L := Index(E, "<"); R := Index(E, ">"); if L = 0 then L := E'First; else L := L + 1; end if; if R = 0 then R := E'Last; else R := R - 1; end if; return E(L..R); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Clean_Email_address (function)"); raise; end Clean_Email_Address; procedure Formail_Concat_Extract_InOut (Header : in String; Source : in String; Target : in String) is E : Integer; pragma Unreferenced(E); begin E := ForkExec_InOut(Value_Nonempty(Config.Binary(Formail)), UBS_Array'(0 => ToUBS("formail"), 1 => ToUBS("-c"), 2 => ToUBS("-x"), 3 => ToUBS(Header)), Source => Source, Target => Target); -- Ignore the return code of formail. It seems to return 1 a -- lot, and I can't find any documentation telling me what it -- _should_ return. end Formail_Concat_Extract_InOut; procedure Formail_Extract_InOut (Header : in String; Source : in String; Target : in String) is E : Integer; pragma Unreferenced(E); begin E := ForkExec_InOut(Value_Nonempty(Config.Binary(Formail)), UBS_Array'(0 => ToUBS("formail"), 1 => ToUBS("-x"), 2 => ToUBS(Header)), Source => Source, Target => Target); -- Ignore the return code of formail. It seems to return 1 a -- lot, and I can't find any documentation telling me what it -- _should_ return. end Formail_Extract_InOut; procedure Formail_Drop_InOut (Header : in UBS_Array; Source : in String; Target : in String) is F : UBS_Array(0..(2*Header'Length)+1); E : Integer; pragma Unreferenced(E); begin F(0) := ToUBS("formail"); F(1) := ToUBS("-f"); -- Don't add mbox From line at start. for I in 1..Header'Length loop F(2*I) := ToUBS("-I"); F((2*I)+1) := Header(I+Header'First-1); end loop; E := ForkExec_InOut(Value_Nonempty(Config.Binary(Formail)), F, Source => Source, Target => Target); -- Ignore the return code of formail. It seems to return 1 a -- lot, and I can't find any documentation telling me what it -- _should_ return. end Formail_Drop_InOut; procedure Formail_Action_InOut (Source : in String; Target : in String; Action : in String) is E : Integer; pragma Unreferenced(E); begin E := ForkExec_InOut(Value_Nonempty(Config.Binary(Formail)), ToUBS("formail -s " & Action), Source => Source, Target => Target); -- Ignore the return code of formail. It seems to return 1 a -- lot, and I can't find any documentation telling me what it -- _should_ return. exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Formail_Action_InOut"); raise; end Formail_Action_InOut; procedure Formail_Replace_Header_InOut (Source : in String; Target : in String; Header : in String) is E : Integer; pragma Unreferenced(E); begin E := ForkExec_InOut(Value_Nonempty(Config.Binary(Formail)), UBS_Array'(0 => ToUBS("formail"), 1 => ToUBS("-f"), 2 => ToUBS("-I"), 3 => ToUBS(Header)), Source => Source, Target => Target); -- Ignore the return code of formail. It seems to return 1 a -- lot, and I can't find any documentation telling me what it -- _should_ return. exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Formail_Replace_Header_InOut"); raise; end Formail_Replace_Header_InOut; -- A temporary file that we'll re-use for formail_action. Formail_Replace_Header_Tempfile : UBS; procedure Formail_Replace_Header (File : in String; Header : in String) is use Ada.Strings.Unbounded; begin if Formail_Replace_Header_Tempfile = Null_Unbounded_String then Formail_Replace_Header_Tempfile := ToUBS(Temp_File_Name("fa")); end if; Formail_Replace_Header_InOut(File, ToStr(Formail_Replace_Header_Tempfile), Header); Externals.Simple.Cat_Out(ToStr(Formail_Replace_Header_Tempfile), File); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Formail_Replace_Header"); raise; end Formail_Replace_Header; subtype Upper_Letters is Character range 'A'..'Z'; package Random_Letters is new Ada.Numerics.Discrete_Random(Upper_Letters); Random_Letters_Generator : Random_Letters.Generator; function Get_Boundary return String is U : UBS; use type UBS; begin U := ToUBS("MIME_CONTENT_BREAK_" & "=_"); -- Add some random stuff. for I in 1..31 loop U := U & Random_Letters.Random(Random_Letters_Generator); end loop; return ToStr(U); end Get_Boundary; procedure Mimeconstruct2 (Part1_Filename : in String; Part2_Filename : in String; Output_Filename : in String; Content_Type : in String; Prolog : in String := "") is begin if Prolog'Length > 0 then if ForkExec_Out(Value_Nonempty(Config.Binary(Mimetool)), UBS_Array'(0 => ToUBS("mime-tool"), 1 => ToUBS("-P"), 2 => ToUBS(Prolog), 3 => ToUBS("-B"), 4 => ToUBS(Get_Boundary), 5 => ToUBS("-O"), 6 => ToUBS(Content_Type), 7 => ToUBS("-o"), 8 => ToUBS("-p"), 9 => ToUBS(Part1_Filename), 10 => ToUBS("-o"), 11 => ToUBS("-p"), 12 => ToUBS(Part2_Filename)), Output_Filename) /= 0 then Error("mime-tool failed. (mff1a)"); end if; else if ForkExec_Out(Value_Nonempty(Config.Binary(Mimetool)), UBS_Array'(0 => ToUBS("mime-tool"), 1 => ToUBS("-B"), 2 => ToUBS(Get_Boundary), 3 => ToUBS("-O"), 4 => ToUBS(Content_Type), 5 => ToUBS("-o"), 6 => ToUBS("-p"), 7 => ToUBS(Part1_Filename), 8 => ToUBS("-o"), 9 => ToUBS("-p"), 10 => ToUBS(Part2_Filename)), Output_Filename) /= 0 then Error("mime-tool failed. (mff1b)"); end if; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Mimeconstruct2"); raise; end Mimeconstruct2; Disposition_String : constant array (Dispositions) of String(1..2) := (None => "-o", -- No disposition line. Inline => "-i", -- Use inline. Attachment => "-0"); -- No-op -- the default is attachment. procedure Mimeconstruct_Subpart (Infile : in String; Outfile : in String; Content_Type : in String; Dos2UnixU : in Boolean; Use_Encoding : in Boolean; Disposition : in Dispositions := None; Encoding : in String := ""; Attachment_Name : in String := "") is Encode : String(1..2); MC : UBS_Array(0..9); begin MC(0) := ToUBS("mime-tool"); MC(1) := ToUBS("-s"); -- Figure out which encoding to use. if Use_Encoding then if Encoding = "base64" then Encode := "-x"; elsif Encoding = "quoted-printable" then Encode := "-q"; elsif Encoding = "7bit" then Encode := "-7"; elsif Encoding = "8bit" then Encode := "-8"; else Encode := "-x"; end if; MC(2) := ToUBS(Encode); MC(3) := ToUBS("-0"); else -- No encoding requested, so we'll set it to binary and omit -- the content-transfer-encoding. MC(2) := ToUBS("-b"); MC(3) := ToUBS("-m"); end if; if Config.Boolean_Opts(Omit_Inline_Disposition_Header) and Disposition = Inline then -- Override it to None. MC(4) := ToUBS(Disposition_String(None)); else MC(4) := ToUBS(Disposition_String(Disposition)); end if; if Disposition = None or (Config.Boolean_Opts(Omit_Inline_Disposition_Header) and Disposition = Inline) then -- Some no-ops: we weren't going to show a name. MC(5) := ToUBS("-0"); MC(6) := ToUBS("-0"); else if Attachment_Name'Length > 0 then -- Should we use this attachment name? if Disposition = Inline and Config.Boolean_Opts(Omit_Inline_Disposition_Name) then -- We don't want the name. MC(5) := ToUBS("-N"); MC(6) := ToUBS("-0"); else -- Use this name. MC(5) := ToUBS("-n"); MC(6) := ToUBS(Attachment_Name); end if; else -- We don't have an attachment name. Let mime-tool sort it out. MC(5) := ToUBS("-0"); MC(6) := ToUBS("-0"); end if; end if; -- The content-type and the file. MC(7) := ToUBS("-c"); MC(8) := ToUBS(Content_Type); MC(9) := ToUBS(Infile); -- Now actually construct the MIME subpart. if ForkExec_Out(Value_Nonempty(Config.Binary(Mimetool)), MC, Outfile) /= 0 then Error("mime-tool failed. (mff3)"); end if; -- Do we need to convert the file with dos2unix? if Dos2UnixU then Externals.Simple.Dos2Unix_U(Outfile); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Mimeconstruct_Subpart"); raise; end Mimeconstruct_Subpart; -- Construct an entire multipart/mixed email. procedure Mimeconstruct_Mixed (Filenames : in UBS_Array; Outfile : in String) is -- Arg array size is ( 3*num-filenames ) +5, but starting at 0. A : UBS_Array(0 .. (3 * Filenames'Length)+4); begin A(0) := ToUBS("mime-tool"); A(1) := ToUBS("-B"); A(2) := ToUBS(Get_Boundary); A(3) := ToUBS("-O"); A(4) := ToUBS("multipart/mixed"); for I in 1..Filenames'Length loop -- First one should be 5. A((3*I)+2) := ToUBS("-o"); A((3*I)+3) := ToUBS("-p"); A((3*I)+4) := Filenames(I+Filenames'First-1); end loop; if ForkExec_Out(Value_Nonempty(Config.Binary(Mimetool)), A, Outfile) /= 0 then Error("mime-tool failed. (mff2)"); end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Mimeconstruct_Mixed"); raise; end Mimeconstruct_Mixed; -- From RFC2045: (A good strategy is to choose a boundary that includes -- a character sequence such as "=_" which can never appear in a -- quoted-printable body. See the definition of multipart messages in -- RFC 2046.) -- Because we might build multiple parts, we'll use a boundary of -- MIME_CONTENT_BREAK_=_(partno)=_(random stuff) -- where partno is a per-topal-run counter. (Later: removed partno) -- Note that mime-tool actually uses --=_%s_= as the boundary. -- We don't currently check for boundary collisions in the data. -- We should. -- Then we call out to our patched version of mime-tool -- View a MIME file. procedure View_MIME (F : in String; Decrypt : in Boolean) is Chosen : Positive; MTF : constant String := Temp_File_Name("vmmt"); MTFE : constant String := Temp_File_Name("vmmte"); MT, MTE : UBS; NC : Boolean := False; NTFE : Boolean := False; CT : UBS; CTE : UBS; Dummy : Integer; F2 : constant String := Temp_File_Name("f2"); pragma Unreferenced(Dummy); begin -- Find out the type of MIME file. Externals.Mail.Extract_Content_Type_From_Header(F, MTF, Ignore_Missing => True); MT := Read_Fold(MTF); Externals.Mail.Extract_Content_Transfer_Encoding_From_Header(F, MTFE, Ignore_Missing => True); MTE := Read_Fold(MTFE); Ada.Text_IO.New_Line(5); declare MTFS : constant String := ToStr(MT); MTFES : constant String := ToStr(MTE); I, I2 : Integer; J, J2 : Integer; begin I := Ada.Strings.Fixed.Index(MTFS, ": "); if I = 0 then I := MTFS'First; NC := True; else I := I + 2; end if; I2 := Ada.Strings.Fixed.Index(MTFS, ";"); if I2 = 0 then I2 := MTFS'Last; else I2 := I2 - 1; end if; J := Ada.Strings.Fixed.Index(MTFES, ": "); if J = 0 then J := MTFES'First; NTFE := True; else J := J + 2; end if; J2 := Ada.Strings.Fixed.Index(MTFES, ";"); if J2 = 0 then J2 := MTFES'Last; else J2 := J2 - 1; end if; if NC then Ada.Text_IO.Put_Line("About to view an attachment with " & Do_SGR(Config.UBS_Opts(Colour_Info)) & "no content type" & Reset_SGR); CT := ToUBS("text/plain"); else Ada.Text_IO.Put_Line("About to view an attachment with " & "content type `" & Do_SGR(Config.UBS_Opts(Colour_Info)) & MTFS(I..I2) & Reset_SGR & "'"); CT := ToUBS(MTFS(I..I2)); end if; if NTFE then Ada.Text_IO.Put_Line(Do_SGR(Config.UBS_Opts(Colour_Info)) & "No content transfer encoding" & Reset_SGR); CTE := ToUBS("7bit"); else CTE := ToUBS(Ada.Strings.Fixed.Translate(MTFES(J..J2), Ada.Strings.Maps.Constants.Lower_Case_Map)); Ada.Text_IO.Put_Line("Content transfer encoding is `" & Do_SGR(Config.UBS_Opts(Colour_Info)) & ToStr(CTE) & Reset_SGR & "'"); end if; end; -- Do we have to ask which viewer...? -- We'll short circuit this in the case of application/(x-)pkcs7-mime and smime-type. This information would get lost in the call. if Ada.Strings.Fixed.Index(Ada.Strings.Fixed.Translate(ToStr(MT), Ada.Strings.Maps.Constants.Lower_Case_Map), "smime-type=signed-data") /= 0 then Chosen := 99; elsif Decrypt then Chosen := Config.Positive_Opts(MIME_Viewer_Decrypt); else Chosen := Config.Positive_Opts(MIME_Viewer_Verify); end if; if Chosen = 1 then -- Ask what we should do. Chosen := MV_Values(MIME_Viewer_Menu2); end if; -- Actually execute the chosen viewer method. case Chosen is when 2 => -- Metamail Ada.Text_IO.Put_Line("Viewing attachment with metamail..."); if ForkExec(Misc.Value_Nonempty(Config.Binary(Metamail)), UBS_Array'(0 => ToUBS("metamail"), 1 => ToUBS(F))) /= 0 then Misc.ErrorNE("metamail failed! (ff5)"); end if; when 3 => -- run-mailcap -- FIXME: Deal with multipart nicely. declare B : constant String := Temp_File_Name("vmb"); B2 : constant String := Temp_File_Name("vmb2"); use type UBS; begin if NC then Ada.Text_IO.Put_Line("Hoping that this is text/plain (no content-type!)"); end if; -- Handle the transfer encoding! If it's QP or base64, -- decode it! Externals.Mail.Extract_Body(F, B); if ToStr(CTE) = "quoted-printable" then QP_Decode(B, B2); Externals.Simple.Cat_Out(B2, B); elsif ToStr(CTE) = "base64" then Base64_Decode(B, B2); Externals.Simple.Cat_Out(B2, B); end if; Ada.Text_IO.Put_Line("Viewing attachment with run-mailcap..."); if ForkExec(Misc.Value_Nonempty(Config.Binary(Runmailcap)), UBS_Array'(0 => ToUBS("run-mailcap"), 1 => CT & ToUBS(":" & B))) /= 0 then Misc.ErrorNE("run-mailcap failed! (ff5)"); end if; end; when 4 => -- Save -- Write out the file to a well-known place. declare VMF : constant String := ToStr(Topal_Directory) & "/viewmime"; begin Externals.Simple.Echo_Append_N("From MAILER-DAEMON ", VMF); Externals.Simple.Date_1_Append("+%a %b %e %H:%M:%S %Y", VMF); Externals.Simple.Echo_Append("From: Topal-MIME-view", VMF); Externals.Simple.Echo_Append_N("Date: ", VMF); Externals.Simple.Date_1_Append("--rfc-2822", VMF); Externals.Simple.Echo_Append("MIME-Version: 1.0", VMF); Externals.Simple.Cat_Append(F, VMF); Ada.Text_IO.Put_Line("Appended email to mbox " & VMF); end; when 5 => -- Skip Ada.Text_IO.Put_Line("Skipping attachment..."); when 99 => -- Invoke topal on this attachment. Ada.Text_IO.Put_Line("Should run Topal on this one."); Externals.Mail.Extract_Body(F, F2); Dummy := Externals.Simple.System("topal -mime " & F2 & " ""application/x-pkcs7-mime; smime-type=signed-data"""); when others => Misc.ErrorNE("Bogus value in Externals.Mail.View_MIME"); end case; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.View_MIME"); raise; end View_MIME; -- Base 64 decode from infile to outfile. -- Uses openssl internally. procedure Base64_Decode (Infile, Outfile : in String) is Dummy : Integer; pragma Unreferenced(Dummy); begin Dummy := ForkExec(Value_Nonempty(Config.Binary(Openssl)), UBS_Array'(0 => ToUBS("openssl"), 1 => ToUBS("base64"), 2 => ToUBS("-d"), 3 => ToUBS("-in"), 4 => ToUBS(Infile), 5 => ToUBS("-out"), 6 => ToUBS(Outfile))); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Base64_Decode"); raise; end Base64_Decode; -- Quoted-printable decode from infile to outfile. procedure QP_Decode (Infile, Outfile : in String) is InF : Ada.Text_IO.File_Type; OutF : Character_IO.File_Type; begin -- Read, character by character, until end-of-line. Ada.Text_IO.Open(File => InF, Mode => Ada.Text_IO.In_File, Name => Infile); Character_IO.Create(File => OutF, Mode => Character_IO.Out_File, Name => Outfile); Decode_Loop: loop begin -- Simple copy. declare U : constant UBS := Unbounded_Get_Line(InF); S : constant String := ToStr(U); I : Integer; H : Integer; Need_NL : Boolean := True; begin -- Walk through S. -- If we see `=', then -- (i) it's at the end of a line: it's a soft line break, so don't output even a newline. -- (ii) it should be followed by two hex characters. decode and print. I := S'First; Char_Loop: while I <= S'Last loop if S(I) = '=' then if I = S'Last then -- Soft line break. Need_NL := False; exit Char_Loop; elsif I+2 > S'Last then -- Overrunning the end of a line? Just print it. Character_IO_Put(OutF, S(I..S'Last)); I := S'Last + 1; else -- Decode. begin H := Hex_Decode(S(I+1..I+2)); Character_IO.Write(OutF, Character'Val(H)); I := I + 3; exception when Constraint_Error => -- Not hex? Ignoring it. Character_IO.Write(OutF, S(I)); I := I + 1; end; end if; else Character_IO.Write(OutF, S(I)); I := I + 1; end if; end loop Char_Loop; if Need_NL then Character_IO.Write(OutF, Ada.Characters.Latin_1.LF); end if; end; exception when Ada.IO_Exceptions.End_Error => exit Decode_Loop; end; end loop Decode_Loop; Ada.Text_IO.Close(File => InF); Character_IO.Close(File => OutF); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.QP_Decode"); raise; end QP_Decode; -- Return SHA1 hash of infile. -- Uses openssl internally. function Hash_SHA1 (Infile : in String) return String is Dummy : Integer; pragma Unreferenced(Dummy); F : constant String := Temp_File_Name("sha1"); begin Dummy := ForkExec_InOut(Value_Nonempty(Config.Binary(Openssl)), UBS_Array'(0 => ToUBS("openssl"), 1 => ToUBS("sha1")), Infile, F); return ToStr(Read_Fold(F)); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Hash_SHA1"); raise; end Hash_SHA1; procedure Replace_Message_ID(Hdrfile : in String; Alt_Sign : in String; Encrypt_Message_ID : in Boolean; Encrypt_Key : in String) is F : constant String := Temp_File_Name("rmid"); E1 : constant String := Temp_File_Name("emid1"); E2 : constant String := Temp_File_Name("emid2"); E3 : constant String := Temp_File_Name("emid3"); EM : UBS; R : String(1..8); ORV : Integer; begin if Encrypt_Message_ID then -- Copy the message-id. Externals.Mail.Formail_Concat_Extract_InOut("Message-ID:", Hdrfile, E1); -- Make cryptogram. EM := ToUBS(Trim_Leading_Spaces(ToStr(Read_Fold(E1)))); Externals.Simple.Echo_Out(ToStr(EM), E2); ORV := Externals.Simple.System(ToStr(Value_Nonempty(Config.Binary(Openssl))) & " enc -e -des3 -pass pass:" & Encrypt_Key & " -a -A -in " & E2 & " -out " & E3); if ORV = 0 then -- Only write it on success. Externals.Simple.Echo_Append("X-Topal-Message-ID: " & Trim_Leading_Spaces(ToStr(Read_Fold(E3))), Hdrfile); end if; end if; -- Munge and randomize the Message-ID (using sed). for I in R'Range loop R(I) := Random_Letters.Random(Random_Letters_Generator); end loop; Externals.Simple.Sed_InOut("s/^\(Message-ID: \)<\([aA]l\)\?[pP]ine\....\..\...\.\(.*\)@\(.*\)>$/\1<\3." & R & "%" & Alt_Sign & ">/", Hdrfile, F); Externals.Simple.Cat_Out(F, Hdrfile); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Replace_Message_ID"); raise; end Replace_Message_ID; procedure Replace_Content_IDs(Tmpfile : in String; Alt_Sign : in String) is F : constant String := Temp_File_Name("rcid"); begin Externals.Simple.Sed_InOut("s/^\(Content-ID: \)<\([aA]l\)\?[pP]ine\....\..\...\.\(.*\)@\(.*\)>$/\1<\3%" & Alt_Sign & ">/", Tmpfile, F); Externals.Simple.Cat_Out(F, Tmpfile); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Replace_Content_IDs"); raise; end Replace_Content_IDs; -- Calculate a token for an X-Topal-Send-Token header. function Calculate_Send_Token(Hdrfile : in String; Per_User_Token : in String) return String is F_Name : constant String := Temp_File_Name("stf"); M_Name : constant String := Temp_File_Name("stm"); H_Name : constant String := Temp_File_Name("sth"); Token : UBS; use type UBS; begin -- Extract the From and Message-ID lines. Externals.Mail.Formail_Concat_Extract_InOut("From: ", Hdrfile, F_Name); Externals.Mail.Formail_Concat_Extract_InOut("Message-ID: ", Hdrfile, M_Name); -- Concatenate them with the token. Token := ToUBS(Per_User_Token) & ':' & Read_Fold(F_Name) & ':' & Read_Fold(M_Name); -- SHA1. -- Add the new header, X-Topal-Send-Token Externals.Simple.Echo_Out(ToStr(Token), H_Name); -- Return it. return Hash_SHA1(H_Name); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Calculate_Send_Token"); raise; end Calculate_Send_Token; procedure Check_Send_Token(Per_User_Token : in String) is In_F : constant String := Temp_File_Name("in"); T_Name1 : constant String := Temp_File_Name("token1"); T_Name2 : constant String := Temp_File_Name("token2"); T_Name3 : constant String := Temp_File_Name("token3"); T_Name4 : constant String := Temp_File_Name("token4"); Token : UBS; begin Externals.Simple.Cat_Stdin_Out(In_F); -- The token should be this: Token := ToUBS(Calculate_Send_Token(In_F, Per_User_Token)); -- Get the current token. Externals.Mail.Formail_Concat_Extract_InOut("X-Topal-Send-Token:", In_F, T_Name1); -- Do they match? if Trim_Leading_Spaces(ToStr(Read_Fold(T_Name1))) = ToStr(Token) then Formail_Replace_Header(In_F, "X-Topal-Check-Send-Token: yes"); else Formail_Replace_Header(In_F, "X-Topal-Check-Send-Token: no"); end if; -- Also, if an X-Topal-Message-ID is present, then see if we can -- calculate it as X-Topal-Original_Message-ID. Externals.Mail.Formail_Concat_Extract_InOut("X-Topal-Message-ID:", In_F, T_Name2); -- FIXME: Of course, another way to do this would be to record the original and altered message-ids…. -- Trim the leading space…. declare MID : constant String := Trim_Leading_Spaces(ToStr(Read_Fold(T_Name2))); D1 : constant String := Temp_File_Name("dmid1"); D2 : constant String := Temp_File_Name("dmid2"); ORV : Integer; begin -- So we now have the string. -- If it's non-empty, we'll assume it's worth decrypting. if MID'Length > 0 then Externals.Simple.Echo_Out(MID, D1); ORV := Externals.Simple.System(ToStr(Value_Nonempty(Config.Binary(Openssl))) & " enc -d -des3 -pass pass:" & Per_User_Token & " -a -A -in " & D1 & " -out " & D2); if ORV = 0 then -- Success, we'll write a new header. Formail_Replace_Header(In_F, "X-Topal-Original-Message-ID: " & Trim_Leading_Spaces(ToStr(Read_Fold(D2)))); end if; end if; end; -- Also, if an X-Topal-Fcce is present, then see if we can -- calculate it as X-Topal-Fcc. Externals.Mail.Formail_Concat_Extract_InOut("X-Topal-Fcce:", In_F, T_Name3); -- Trim the leading space…. declare MID : constant String := Trim_Leading_Spaces(ToStr(Read_Fold(T_Name3))); D1 : constant String := Temp_File_Name("dmid1"); D2 : constant String := Temp_File_Name("dmid2"); ORV : Integer; begin -- So we now have the string. -- If it's non-empty, we'll assume it's worth decrypting. if MID'Length > 0 then Externals.Simple.Echo_Out(MID, D1); ORV := Externals.Simple.System(ToStr(Value_Nonempty(Config.Binary(Openssl))) & " enc -d -des3 -pass pass:" & Per_User_Token & " -a -A -in " & D1 & " -out " & D2); if ORV = 0 then -- Success, we'll write a new header. Formail_Replace_Header(In_F, "X-Topal-Fcc: " & Trim_Leading_Spaces(ToStr(Read_Fold(D2)))); end if; end if; end; -- Also, if an X-Topal-Bcce is present, then see if we can -- calculate it as X-Topal-Bcc. Externals.Mail.Formail_Extract_InOut("X-Topal-Bcce:", In_F, T_Name4); -- Trim the leading space…. declare MID : constant String := Trim_Leading_Spaces(ToStr(Read_Fold(T_Name4, Include_LF => True))); D1 : constant String := Temp_File_Name("dmid1"); D2 : constant String := Temp_File_Name("dmid2"); ORV : Integer; begin -- So we now have the string. -- If it's non-empty, we'll assume it's worth decrypting. if MID'Length > 0 then Externals.Simple.Sed_InOut("s/^ //", T_Name4, D1); ORV := Externals.Simple.System(ToStr(Value_Nonempty(Config.Binary(Openssl))) & " enc -d -des3 -pass pass:" & Per_User_Token & " -a -in " & D1 & " -out " & D2); if ORV = 0 then -- Success, we'll write a new header. Formail_Replace_Header(In_F, "X-Topal-Bcc: " & Trim_Leading_Spaces(ToStr(Read_Fold(D2, Include_LF => True)))); end if; end if; end; -- Finally, write out the file (we're a filter!). Externals.Simple.Cat(In_F); exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Check_Send_Token"); raise; end Check_Send_Token; procedure Replace_Fcc(Hdrfile : in String; Encrypt_Key : in String) is E1 : constant String := Temp_File_Name("efcc1"); E2 : constant String := Temp_File_Name("efcc2"); E3 : constant String := Temp_File_Name("efcc3"); E4 : constant String := Temp_File_Name("efcc4"); EM : UBS; ORV : Integer; begin -- Copy X-Topal-Fcc. Externals.Mail.Formail_Concat_Extract_InOut("X-Topal-Fcc:", Hdrfile, E1); -- Make cryptogram. EM := ToUBS(Trim_Leading_Spaces(ToStr(Read_Fold(E1)))); if Ada.Strings.Unbounded.Length(EM) > 0 then -- Non-empty. Externals.Simple.Echo_Out(ToStr(EM), E2); ORV := Externals.Simple.System(ToStr(Value_Nonempty(Config.Binary(Openssl))) & " enc -e -des3 -pass pass:" & Encrypt_Key & " -a -A -in " & E2 & " -out " & E3); if ORV = 0 then -- Only write it on success. Externals.Simple.Echo_Append_N("X-Topal-Fcce: " & Trim_Leading_Spaces(ToStr(Read_Fold(E3))), Hdrfile); -- Remove the old header. Formail_Drop_InOut(UBS_Array'(1 => ToUBS("X-Topal-Fcc:")), Hdrfile, E4); -- This seems to leave a trailing blank line often. We -- need to remove it. Externals.Simple.Rm_File(Hdrfile); Delete_Trailing_Blank_Lines(E4, Hdrfile); end if; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Replace_Fcc"); raise; end Replace_Fcc; procedure Add_Bcc(Hdrfile : in String; Encrypt_Key : in String) is E1 : constant String := Temp_File_Name("ebcc1"); E2 : constant String := Temp_File_Name("ebcc2"); E3 : constant String := Temp_File_Name("ebcc3"); E4 : constant String := Temp_File_Name("ebcc4"); EM : UBS; ORV : Integer; begin -- Copy Bcc. Externals.Mail.Formail_Concat_Extract_InOut("Bcc:", Hdrfile, E1); -- Make cryptogram. EM := ToUBS(Trim_Leading_Spaces(ToStr(Read_Fold(E1)))); if Ada.Strings.Unbounded.Length(EM) > 0 then -- Non-empty. Externals.Simple.Echo_Out(ToStr(EM), E2); ORV := Externals.Simple.System(ToStr(Value_Nonempty(Config.Binary(Openssl))) & " enc -e -des3 -pass pass:" & Encrypt_Key -- Note that we allow folding! -- No -A! & " -a -in " & E2 & " -out " & E3); if ORV = 0 then -- Only write it on success. Externals.Simple.Echo_Append_N("X-Topal-Bcce: ", Hdrfile); -- Prefix each line other than the first with a space. Externals.Simple.Sed_InOut("1! s/^/ /", E3, E4); Externals.Simple.Cat_Append(E4, Hdrfile); -- Mustn't remove Bcc! end if; end if; exception when others => Ada.Text_IO.Put_Line(Ada.Text_IO.Standard_Error, "Exception raised in Externals.Mail.Add_Bcc"); raise; end Add_Bcc; begin Random_Letters.Reset(Random_Letters_Generator); end Externals.Mail;