File : src/aws-pop.adb
------------------------------------------------------------------------------
-- Ada Web Server --
-- P O P - Post Office Protocol --
-- --
-- Copyright (C) 2003-2004 --
-- ACT-Europe --
-- --
-- Authors: Dmitriy Anisimkov - Pascal Obry --
-- --
-- This library 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 library 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 library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
------------------------------------------------------------------------------
-- $Id: aws-pop.adb,v 1.12 2004/02/08 20:58:05 obry Exp $
with Ada.Exceptions;
with AWS.Headers.Set;
with Ada.Streams.Stream_IO;
with Ada.Strings.Fixed;
with Ada.Unchecked_Deallocation;
with AWS.Headers.Values;
with AWS.Messages;
with AWS.Net.Buffered;
with AWS.Resources.Streams.Memory;
with AWS.Translator;
with AWS.Utils;
with MD5;
with Strings_Cutter;
package body AWS.POP is
use Ada.Exceptions;
-- MIME Headers
subtype Stream_Type is AWS.Resources.Streams.Memory.Stream_Type;
CRLF : constant String := ASCII.CR & ASCII.LF;
procedure Check_Response (Response : in String);
-- Checks server's response, raise POP_Error with server's message
------------
-- Adjust --
------------
procedure Adjust (Attachment : in out POP.Attachment) is
begin
Attachment.Ref_Count.all := Attachment.Ref_Count.all + 1;
end Adjust;
procedure Adjust (Message : in out POP.Message) is
begin
Message.Ref_Count.all := Message.Ref_Count.all + 1;
end Adjust;
----------------------
-- Attachment_Count --
----------------------
function Attachment_Count (Message : in POP.Message) return Natural is
Count : Natural := 0;
Ptr : Attachment_Access := Message.Attachments;
begin
while Ptr /= null loop
Count := Count + 1;
Ptr := Ptr.Next;
end loop;
return Count;
end Attachment_Count;
--------
-- CC --
--------
function CC (Message : in POP.Message; N : Natural := 0) return String is
CC_Values : constant String := Header (Message, "CC");
Cut_CC : Strings_Cutter.Cut_String;
begin
if N = 0 then
return CC_Values;
else
Strings_Cutter.Create (Cut_CC, CC_Values, ",");
declare
Result : constant String := Strings_Cutter.Field (Cut_CC, N);
begin
Strings_Cutter.Destroy (Cut_CC);
return Strings.Fixed.Trim (Result, Strings.Both);
end;
end if;
end CC;
--------------
-- CC_Count --
--------------
function CC_Count (Message : in POP.Message) return Natural is
CC_Values : constant String := Header (Message, "CC");
begin
if CC_Values = "" then
return 0;
else
return Strings.Fixed.Count (CC_Values, ",") + 1;
end if;
end CC_Count;
--------------------
-- Check_Response --
--------------------
procedure Check_Response (Response : in String) is
begin
if Response'Length > 3
and then Response (Response'First .. Response'First + 3) = "-ERR"
then
Raise_Exception
(POP_Error'Identity,
Response (Response'First + 5 .. Response'Last));
end if;
end Check_Response;
-----------
-- Close --
-----------
procedure Close (Mailbox : in POP.Mailbox) is
begin
-- Send command
Net.Buffered.Put_Line (Mailbox.Sock, "QUIT");
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
end;
Net.Std.Shutdown (Mailbox.Sock);
exception
when POP_Error =>
Net.Std.Shutdown (Mailbox.Sock);
raise;
end Close;
-------------
-- Content --
-------------
function Content (Message : in POP.Message) return Unbounded_String is
begin
return Message.Content;
end Content;
function Content
(Attachment : in POP.Attachment)
return AWS.Resources.Streams.Stream_Access is
begin
return Attachment.Content;
end Content;
function Content (Attachment : in POP.Attachment) return Unbounded_String is
use AWS.Resources.Streams;
Stream : Stream_Type renames Stream_Type (Attachment.Content.all);
Result : Unbounded_String;
Buffer : Streams.Stream_Element_Array (1 .. 4_096);
Last : Streams.Stream_Element_Offset;
begin
if Is_File (Attachment) then
Raise_Exception
(Constraint_Error'Identity,
"This is a file attachment, can't return unbounded_string");
end if;
Memory.Reset (Stream);
while not Memory.End_Of_File (Stream) loop
Memory.Read (Stream, Buffer, Last);
Append (Result, Translator.To_Unbounded_String (Buffer (1 .. Last)));
end loop;
return Result;
end Content;
----------
-- Date --
----------
function Date (Message : in POP.Message) return String is
begin
return Header (Message, "Date");
end Date;
------------
-- Delete --
------------
procedure Delete
(Mailbox : in POP.Mailbox;
N : in Positive) is
begin
Net.Buffered.Put_Line (Mailbox.Sock, "DELE " & Utils.Image (N));
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
end;
end Delete;
--------------
-- Filename --
--------------
function Filename (Attachment : in POP.Attachment) return String is
begin
return To_String (Attachment.Filename);
end Filename;
--------------
-- Finalize --
--------------
procedure Finalize (Attachment : in out POP.Attachment) is
procedure Free is new Unchecked_Deallocation
(AWS.Resources.Streams.Stream_Type'Class,
AWS.Resources.Streams.Stream_Access);
begin
Attachment.Ref_Count.all := Attachment.Ref_Count.all + 1;
if Attachment.Ref_Count.all = 0 then
Headers.Set.Free (Attachment.Headers);
AWS.Resources.Streams.Memory.Close
(Stream_Type (Attachment.Content.all));
Free (Attachment.Content);
end if;
end Finalize;
procedure Finalize (Message : in out POP.Message) is
A : Attachment_Access := Message.Attachments;
begin
Message.Ref_Count.all := Message.Ref_Count.all + 1;
if Message.Ref_Count.all = 0 then
Headers.Set.Free (Message.Headers);
end if;
while A /= null loop
Finalize (A.all);
A := A.Next;
end loop;
end Finalize;
--------------------------
-- For_Every_Attachment --
--------------------------
procedure For_Every_Attachment (Message : in POP.Message) is
P : Attachment_Access := Message.Attachments;
Index : Positive := 1;
Quit : Boolean := False;
begin
while P /= null loop
Action (P.all, Index, Quit);
exit when Quit;
P := P.Next;
Index := Index + 1;
end loop;
end For_Every_Attachment;
-----------------------
-- For_Every_Message --
-----------------------
procedure For_Every_Message
(Mailbox : in POP.Mailbox;
Remove : in Boolean := False)
is
Mess : Message;
Quit : Boolean := False;
begin
for K in 1 .. Mailbox.Message_Count loop
Mess := Get (Mailbox, K, Remove);
Action (Mess, K, Quit);
exit when Quit;
end loop;
end For_Every_Message;
------------------------------
-- For_Every_Message_Header --
------------------------------
procedure For_Every_Message_Header (Mailbox : in POP.Mailbox) is
Mess : Message;
Quit : Boolean := False;
begin
for K in 1 .. Mailbox.Message_Count loop
Mess := Get_Header (Mailbox, K);
Action (Mess, K, Quit);
exit when Quit;
end loop;
end For_Every_Message_Header;
----------
-- From --
----------
function From (Message : in POP.Message) return String is
begin
return Header (Message, "From");
end From;
---------
-- Get --
---------
function Get
(Mailbox : in POP.Mailbox;
N : in Positive;
Remove : in Boolean := False)
return Message
is
procedure Get
(Mailbox : in POP.Mailbox;
Boundary : in String;
Attachment : out POP.Attachment;
Last : out Boolean);
---------
-- Get --
---------
procedure Get
(Mailbox : in POP.Mailbox;
Boundary : in String;
Attachment : out POP.Attachment;
Last : out Boolean)
is
End_Boundary : constant String := Boundary & "--";
Base64 : Boolean := False;
begin
Attachment.Content := new Stream_Type;
-- Read headers
AWS.Headers.Set.Read (Mailbox.Sock, Attachment.Headers);
-- Check Base64 encoding
Base64 := Headers.Get
(Attachment.Headers,
Messages.Content_Transfer_Encoding_Token) = "base64";
-- Check for filename
declare
Filename : constant String
:= Headers.Values.Search
(Headers.Get
(Attachment.Headers,
Messages.Content_Disposition_Token),
"filename");
begin
if Filename /= "" then
Attachment.Filename := To_Unbounded_String (Filename);
end if;
end;
-- Read content
loop
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Last := Response = End_Boundary;
exit when Response = Boundary or else Last;
if Base64 then
AWS.Resources.Streams.Memory.Append
(Stream_Type (Attachment.Content.all),
Translator.Base64_Decode (Response));
else
AWS.Resources.Streams.Memory.Append
(Stream_Type (Attachment.Content.all),
Translator.To_Stream_Element_Array (Response & CRLF));
end if;
end;
end loop;
end Get;
Mess : Message;
Boundary : Unbounded_String;
begin
-- Send command
Net.Buffered.Put_Line (Mailbox.Sock, "RETR " & Utils.Image (N));
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
end;
-- Read headers
AWS.Headers.Set.Read (Mailbox.Sock, Mess.Headers);
-- Check for MIME message
declare
Boundary_Field : constant String
:= Headers.Values.Search
(Headers.Get (Mess.Headers, Messages.Content_Type_Token),
"boundary");
begin
if Boundary_Field /= "" then
Boundary := To_Unbounded_String ("--" & Boundary_Field);
end if;
end;
if Boundary = Null_Unbounded_String then
-- Read content
loop
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
exit when Response = ".";
Append (Mess.Content, Response & CRLF);
end;
end loop;
else
-- Skip first boundary
loop
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
exit when Response = To_String (Boundary);
Append (Mess.Content, Response & CRLF);
end;
end loop;
-- Read all attachments
loop
declare
A : Attachment;
Last : Boolean;
begin
Get (Mailbox, To_String (Boundary), A, Last);
if Mess.Last = null then
Mess.Attachments := new Attachment'(A);
Mess.Last := Mess.Attachments;
else
Mess.Last.Next := new Attachment'(A);
Mess.Last := Mess.Last.Next;
end if;
exit when Last;
end;
end loop;
-- Now read until the end of the message body
loop
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
exit when Response = ".";
end;
end loop;
end if;
-- Remove message from server
if Remove then
Delete (Mailbox, N);
end if;
return Mess;
end Get;
function Get
(Message : in POP.Message'Class;
Attachment : in Positive)
return Attachment
is
P : Attachment_Access := Message.Attachments;
begin
for K in 2 .. Attachment loop
if P = null then
Raise_Exception
(Constraint_Error'Identity, "No such attachment");
end if;
P := P.Next;
end loop;
return P.all;
end Get;
----------------
-- Get_Header --
----------------
function Get_Header
(Mailbox : in POP.Mailbox;
N : in Positive)
return Message
is
Mess : Message;
begin
-- Send command to get the message size
Net.Buffered.Put_Line (Mailbox.Sock, "LIST " & Utils.Image (N));
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
K : Natural;
begin
Check_Response (Response);
K := Strings.Fixed.Index (Response, " ", Strings.Backward);
Mess.Size := Natural'Value (Response (K + 1 .. Response'Last));
end;
-- Send command to get the message header
Net.Buffered.Put_Line (Mailbox.Sock, "TOP " & Utils.Image (N) & " 0");
-- Read 0 line from the body
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
end;
-- Read headers
AWS.Headers.Set.Read (Mailbox.Sock, Mess.Headers);
-- Now read until the end of the message body, should read a single
-- line with a dot.
loop
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
exit when Response = ".";
end;
end loop;
return Mess;
end Get_Header;
------------
-- Header --
------------
function Header
(Message : in POP.Message;
Header : in String)
return String is
begin
return Headers.Get (Message.Headers, Header);
end Header;
----------------
-- Initialize --
----------------
procedure Initialize (Message : in out POP.Message) is
begin
Message.Ref_Count := new Natural'(0);
end Initialize;
procedure Initialize (Attachment : in out POP.Attachment) is
begin
Attachment.Ref_Count := new Natural'(0);
end Initialize;
function Initialize
(Server_Name : in String;
User : in String;
Password : in String;
Authenticate : in Authenticate_Mode := Clear_Text;
Port : in Positive := Default_POP_Port)
return Mailbox
is
Timestamp : Unbounded_String;
Mailbox : POP.Mailbox;
begin
Mailbox.Name := To_Unbounded_String (Server_Name);
Mailbox.Sock := Net.Std.Socket_Type (Net.Socket (False).all);
-- Connect to the server
Net.Std.Connect (Mailbox.Sock, Server_Name, Port);
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
-- Everything ok, let's retreive the timestamp if present
if Authenticate = APOP then
declare
First, Last : Natural;
begin
First := Strings.Fixed.Index (Response, "<", Strings.Backward);
Last := Strings.Fixed.Index (Response, ">", Strings.Backward);
if First /= 0 and then Last /= 0 then
Timestamp := To_Unbounded_String (Response (First .. Last));
else
Raise_Exception
(POP_Error'Identity,
"APOP authentication not supported by server.");
end if;
end;
end if;
end;
-- Authenticate
if Authenticate = Clear_Text then
Net.Buffered.Put_Line (Mailbox.Sock, "USER " & User);
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
end;
Net.Buffered.Put_Line (Mailbox.Sock, "PASS " & Password);
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
end;
else
Net.Buffered.Put_Line
(Mailbox.Sock, "APOP " & User
& MD5.Digest (To_String (Timestamp) & Password));
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
end;
end if;
-- Checks for mailbox's content
Net.Buffered.Put_Line (Mailbox.Sock, "STAT");
declare
Response : constant String
:= Net.Buffered.Get_Line (Mailbox.Sock);
begin
Check_Response (Response);
declare
K : Natural;
begin
K := Strings.Fixed.Index (Response, " ", Strings.Backward);
Mailbox.Message_Count
:= Natural'Value (Response (Response'First + 4 .. K - 1));
Mailbox.Size
:= Natural'Value (Response (K + 1 .. Response'Last));
end;
end;
return Mailbox;
exception
when POP_Error =>
Net.Std.Shutdown (Mailbox.Sock);
raise;
end Initialize;
-------------
-- Is_File --
-------------
function Is_File (Attachment : in POP.Attachment) return Boolean is
begin
return Attachment.Filename /= Null_Unbounded_String;
end Is_File;
-------------------
-- Message_Count --
-------------------
function Message_Count (Mailbox : in POP.Mailbox) return Natural is
begin
return Mailbox.Message_Count;
end Message_Count;
----------
-- Size --
----------
function Size (Mailbox : in POP.Mailbox) return Natural is
begin
return Mailbox.Size;
end Size;
function Size (Message : in POP.Message) return Natural is
begin
return Message.Size;
end Size;
-------------
-- Subject --
-------------
function Subject (Message : in POP.Message) return String is
begin
return Header (Message, "Subject");
end Subject;
---------------
-- User_Name --
---------------
function User_Name (Mailbox : in POP.Mailbox) return String is
begin
return To_String (Mailbox.User_Name);
end User_Name;
-----------
-- Write --
-----------
procedure Write (Attachment : in POP.Attachment; Directory : in String) is
use Streams;
use AWS.Resources.Streams;
Stream : Stream_Type renames Stream_Type (Attachment.Content.all);
File : Stream_IO.File_Type;
Buffer : Streams.Stream_Element_Array (1 .. 4_096);
Last : Streams.Stream_Element_Offset;
begin
if not Is_File (Attachment) then
Raise_Exception
(Constraint_Error'Identity,
"This is not a file attachment, can't write content to a file.");
end if;
Stream_IO.Create
(File, Stream_IO.Out_File,
Directory & "/" & To_String (Attachment.Filename));
Memory.Reset (Stream);
while not Memory.End_Of_File (Stream) loop
Memory.Read (Stream, Buffer, Last);
Stream_IO.Write (File, Buffer (1 .. Last));
end loop;
Stream_IO.Close (File);
end Write;
end AWS.POP;