------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté --
-- --
-- Permission to use, copy, modify, and distribute this software for any --
-- purpose with or without fee is hereby granted, provided that the above --
-- copyright notice and this permission notice appear in all copies. --
-- --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. --
------------------------------------------------------------------------------
with Ada.Command_Line;
with Ada.Streams;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Ada.Text_IO.Text_Streams;
with Natools.Getopt_Long;
with Natools.S_Expressions;
with Natools.S_Expressions.Encodings;
procedure HMAC.Main is
procedure Base64_Output (Digest : in Ada.Streams.Stream_Element_Array);
-- Output the given binary Digest in base-64
procedure Lower_Hex_Output (Digest : in Ada.Streams.Stream_Element_Array);
-- Output the given binary Digest in lower-case hexadecimal
procedure Raw_Output (Digest : in Ada.Streams.Stream_Element_Array);
-- Output the given binary Direct directly
procedure Upper_Hex_Output (Digest : in Ada.Streams.Stream_Element_Array);
-- Output the given binary Digest in upper-case hexadecimal
package Options is
type Id is
(Base64_Output,
Lower_Hex_Output,
Raw_Output,
Upper_Hex_Output);
end Options;
package Getopt is new Natools.Getopt_Long (Options.Id);
type Encode_Output is not null access procedure
(Digest : in Ada.Streams.Stream_Element_Array);
type Callback is new Getopt.Handlers.Callback with record
Output : Encode_Output := Lower_Hex_Output'Access;
Key : Ada.Strings.Unbounded.Unbounded_String;
Has_Key : Boolean := False;
Done : Boolean := False;
end record;
overriding procedure Option
(Handler : in out Callback;
Id : in Options.Id;
Argument : in String);
overriding procedure Argument
(Handler : in out Callback;
Argument : in String);
overriding procedure Option
(Handler : in out Callback;
Id : in Options.Id;
Argument : in String)
is
pragma Unreferenced (Argument);
begin
case Id is
when Options.Base64_Output =>
Handler.Output := Base64_Output'Access;
when Options.Lower_Hex_Output =>
Handler.Output := Lower_Hex_Output'Access;
when Options.Raw_Output =>
Handler.Output := Raw_Output'Access;
when Options.Upper_Hex_Output =>
Handler.Output := Upper_Hex_Output'Access;
end case;
end Option;
overriding procedure Argument
(Handler : in out Callback;
Argument : in String) is
begin
if Handler.Has_Key then
Handler.Output (HMAC_Implementation.Digest
(Ada.Strings.Unbounded.To_String (Handler.Key),
Natools.S_Expressions.To_Atom (Argument)));
Handler.Done := True;
else
Handler.Key := Ada.Strings.Unbounded.To_Unbounded_String (Argument);
Handler.Has_Key := True;
end if;
end Argument;
procedure Base64_Output (Digest : in Ada.Streams.Stream_Element_Array) is
begin
Ada.Text_IO.Put_Line (Natools.S_Expressions.To_String
(Natools.S_Expressions.Encodings.Encode_Base64 (Digest)));
end Base64_Output;
procedure Lower_Hex_Output (Digest : in Ada.Streams.Stream_Element_Array) is
begin
Ada.Text_IO.Put_Line (Natools.S_Expressions.To_String
(Natools.S_Expressions.Encodings.Encode_Hex
(Digest, Natools.S_Expressions.Encodings.Lower)));
end Lower_Hex_Output;
procedure Raw_Output (Digest : in Ada.Streams.Stream_Element_Array) is
begin
Ada.Text_IO.Text_Streams.Stream (Ada.Text_IO.Current_Output).Write
(Digest);
end Raw_Output;
procedure Upper_Hex_Output (Digest : in Ada.Streams.Stream_Element_Array) is
begin
Ada.Text_IO.Put_Line (Natools.S_Expressions.To_String
(Natools.S_Expressions.Encodings.Encode_Hex
(Digest, Natools.S_Expressions.Encodings.Upper)));
end Upper_Hex_Output;
Opt_Config : Getopt.Configuration;
Handler : Callback;
begin
Opt_Config.Add_Option
("base64", 'b', Getopt.No_Argument, Options.Base64_Output);
Opt_Config.Add_Option
("lower-hex", 'h', Getopt.No_Argument, Options.Lower_Hex_Output);
Opt_Config.Add_Option
("raw", 'r', Getopt.No_Argument, Options.Raw_Output);
Opt_Config.Add_Option
("upper-hex", 'H', Getopt.No_Argument, Options.Upper_Hex_Output);
Opt_Config.Process (Handler);
if not Handler.Has_Key then
Ada.Text_IO.Put_Line ("Usage: "
& Ada.Command_Line.Command_Name
& "[-h | -H | -b | -r] key [message]");
elsif not Handler.Done then
declare
Context : HMAC_Implementation.Context
:= HMAC_Implementation.Create
(Ada.Strings.Unbounded.To_String (Handler.Key));
Block : Ada.Streams.Stream_Element_Array (1 .. 64);
Last : Ada.Streams.Stream_Element_Offset;
Input : constant Ada.Text_IO.Text_Streams.Stream_Access
:= Ada.Text_IO.Text_Streams.Stream (Ada.Text_IO.Current_Input);
begin
loop
Input.Read (Block, Last);
exit when Last not in Block'Range;
HMAC_Implementation.Update
(Context, Block (Block'First .. Last));
end loop;
Handler.Output (HMAC_Implementation.Digest (Context));
end;
end if;
end HMAC.Main;