Natools

-- 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.Exceptions;
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;
with Natools.S_Expressions.File_Readers;

with HMAC.Pinentry;

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);

   package Options is
      type Id is
        (Base64_Output,
         Key_File,
         Lower_Hex_Output,
         Pinentry,
         Raw_Output,
         Upper_Hex_Output);
   end Options;

   package Getopt is new Natools.Getopt_Long (Options.Id);

   type Encode_Output is not null access procedure

                 (Natools.S_Expressions.To_String
                    (Natools.S_Expressions.File_Readers.Reader
                       (Argument).Read));
            end if;
            Handler.Has_Key := True;
         when Options.Lower_Hex_Output =>
            Handler.Output := Lower_Hex_Output'Access;
         when Options.Pinentry =>
            begin
               Handler.Key := Ada.Strings.Unbounded.To_Unbounded_String
                 (Pinentry.Get_Key (Argument));
               Handler.Has_Key := True;
            exception
               when Ex : others =>
                  Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                     "Unable to get PIN from """ & Argument & '"');
                  Ada.Text_IO.Put_Line (Ada.Text_IO.Current_Error,
                     "exception " & Ada.Exceptions.Exception_Name (Ex)
                     & ": " & Ada.Exceptions.Exception_Message (Ex));
            end;
         when Options.Raw_Output =>
            Handler.Output := Raw_Output'Access;
         when Options.Upper_Hex_Output =>
            Handler.Output := Upper_Hex_Output'Access;
      end case;
   end Option;

     ("key-file", 'f', Getopt.Required_Argument, Options.Key_File);
   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);

   if Pinentry.Is_Available then
      Opt_Config.Add_Option
        ("pinentry", 'p', Getopt.Required_Argument, Options.Pinentry);
   end if;

   Opt_Config.Process (Handler);

   if not Handler.Has_Key then
      Ada.Text_IO.Put_Line ("Usage:");
      Ada.Text_IO.Put_Line ("   "
        & Ada.Command_Line.Command_Name
        & " [-h | -H | -b | -r] key [message]");
      Ada.Text_IO.Put_Line ("   "
        & Ada.Command_Line.Command_Name
        & " [-h | -H | -b | -r] -f path/to/key/file [message]");

      if Pinentry.Is_Available then
         Ada.Text_IO.Put_Line ("   "
           & Ada.Command_Line.Command_Name
           & " [-h | -H | -b | -r] -p path/to/bin/pinentry [message]");
      end if;

   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);

------------------------------------------------------------------------------
-- 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- This is the default empty (but portable) non-working implementation of   --
-- HMAC.Pinentry.                                                           --
------------------------------------------------------------------------------


package body HMAC.Pinentry is

   function Get_Key (Command : String) return String is
   begin
      raise Backend_Error
        with "HMAC.Pinentry is not implemented on this platform.";
      return "";
   end Get_Key;


   function Is_Available return Boolean is
   begin
      return False;
   end Is_Available;

end HMAC.Pinentry;

------------------------------------------------------------------------------
-- 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- HMAC.Pinentry encapsulates communication with `pinentry` utility from    --
-- GnuPG project.                                                           --
-- Depending on communication features available, the package might not be  --
-- functional on all targets. A client should use Is_Available function to  --
-- ensure the underlying implentation is indeed operational.                --
------------------------------------------------------------------------------

package HMAC.Pinentry is

   Backend_Error : exception;

   function Get_Key (Command : String) return String;
      --  Run the given Command and communicate with it using pinentry protocol
      --  and return a secret String or raise Backend_Error.

   function Is_Available return Boolean;
      --  Check whether Get_Key can actually work

end HMAC.Pinentry;

------------------------------------------------------------------------------
-- 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.Environment_Variables;
with Ada.Streams;

with POSIX.IO;
with POSIX.Process_Identification;
with POSIX.Process_Primitives;

with Natools.S_Expressions;

package body HMAC.Pinentry is

   procedure Check_OK (Fd : POSIX.IO.File_Descriptor);
      --  Check that pinentry OK response is coming through Fd

   procedure Check_OK
     (Receive, Send : in POSIX.IO.File_Descriptor;
      Command : in String);
      --  Send Command and wait for OK response

   function Read_Line (Fd : POSIX.IO.File_Descriptor) return String;
      --  Read a single line from Fd, aussming it will be smaller than 1 kb

   procedure Send_Command
     (Send : in POSIX.IO.File_Descriptor;
      Command : in String);
      --  Send Command through the given file descriptor



   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Check_OK (Fd : POSIX.IO.File_Descriptor) is
      Line : constant String := Read_Line (Fd);
   begin
      if Line'Length < 2
        or else Line (Line'First .. Line'First + 1) /= "OK"
      then
         raise Backend_Error with "Not-OK response """ & Line & '"';
      end if;
   end Check_OK;


   procedure Check_OK
     (Receive, Send : in POSIX.IO.File_Descriptor;
      Command : in String) is
   begin
      Send_Command (Send, Command);
      Check_OK (Receive);
   end Check_OK;


   function Read_Line (Fd : POSIX.IO.File_Descriptor) return String is
      Buffer : Ada.Streams.Stream_Element_Array (1 .. 1024);
      Next : Ada.Streams.Stream_Element_Offset := Buffer'First;
      Result : Ada.Streams.Stream_Element_Offset;

      use type Ada.Streams.Stream_Element;
      use type Ada.Streams.Stream_Element_Offset;
   begin
      loop
         POSIX.IO.Read (Fd, Buffer (Next .. Next), Result);
         exit when Result /= Next or else Buffer (Next) = 10;
         Next := Next + 1;
      end loop;

      return Natools.S_Expressions.To_String
        (Buffer (Buffer'First .. Next - 1));
   end Read_Line;


   procedure Send_Command
     (Send : in POSIX.IO.File_Descriptor;
      Command : in String)
   is
      Last : Ada.Streams.Stream_Element_Offset;
   begin
      if Command'Length > 0 then
         POSIX.IO.Write
           (Send,
            Natools.S_Expressions.To_Atom (Command & Character'Val (10)),
            Last);
      end if;
   end Send_Command;



   ----------------------
   -- Public Interface --
   ----------------------

   function Get_Key (Command : String) return String is
      Local_Send, Local_Receive : POSIX.IO.File_Descriptor;
      Remote_Send, Remote_Receive : POSIX.IO.File_Descriptor;
      Template : POSIX.Process_Primitives.Process_Template;
      Pid : POSIX.Process_Identification.Process_ID;
      Args : POSIX.POSIX_String_List;
   begin
      POSIX.Append (Args, POSIX.To_POSIX_String (Command));
      if Ada.Environment_Variables.Exists ("DISPLAY") then
         POSIX.Append (Args, POSIX.To_POSIX_String (String'("--display")));
         POSIX.Append (Args, POSIX.To_POSIX_String
           (Ada.Environment_Variables.Value ("DISPLAY")));
      end if;

      POSIX.IO.Create_Pipe (Local_Receive, Remote_Send);
      POSIX.IO.Create_Pipe (Remote_Receive, Local_Send);

      POSIX.Process_Primitives.Open_Template (Template);
      POSIX.Process_Primitives.Set_File_Action_To_Duplicate
        (Template => Template,
         File => POSIX.IO.Standard_Input,
         From_File => Remote_Receive);
      POSIX.Process_Primitives.Set_File_Action_To_Duplicate
        (Template => Template,
         File => POSIX.IO.Standard_Output,
         From_File => Remote_Send);
      POSIX.Process_Primitives.Set_File_Action_To_Close
        (Template, Local_Send);
      POSIX.Process_Primitives.Set_File_Action_To_Close
        (Template, Local_Receive);


      POSIX.Process_Primitives.Start_Process_Search
        (Pid,
         POSIX.Value (Args, 1),
         Template,
         Args);
      POSIX.Process_Primitives.Close_Template (Template);
      POSIX.Make_Empty (Args);

      Check_OK (Local_Receive);

      if POSIX.IO.Is_A_Terminal (POSIX.IO.Standard_Input) then
         Check_OK (Local_Receive, Local_Send, "OPTION ttyname="
            & POSIX.To_String
              (POSIX.IO.Get_Terminal_Name (POSIX.IO.Standard_Input)));
      end if;

      if Ada.Environment_Variables.Exists ("TERM") then
         Check_OK (Local_Receive, Local_Send,
            "OPTION ttytype=" & Ada.Environment_Variables.Value ("TERM"));
      end if;

      if Ada.Environment_Variables.Exists ("LC_CTYPE") then
         Check_OK (Local_Receive, Local_Send,
            "OPTION lc-ctype=" & Ada.Environment_Variables.Value ("LC_CTYPE"));
      end if;

      Send_Command (Local_Send, "GETPIN");
      declare
         Response : constant String := Read_Line (Local_Receive);
      begin

         if Response'Length < 2
           or else Response (Response'First .. Response'First + 1) /= "D "
         then
            raise Backend_Error with "Unexpected response to GETPIN: """
              & Response & '"';
         end if;

         Check_OK (Local_Receive);

         POSIX.IO.Close (Local_Send);
         POSIX.IO.Close (Local_Receive);
         POSIX.IO.Close (Remote_Send);
         POSIX.IO.Close (Remote_Receive);

         return Response (Response'First + 2 .. Response'Last);
      end;
   exception
      when others =>
         POSIX.Process_Primitives.Close_Template (Template);
         POSIX.Make_Empty (Args);
         POSIX.IO.Close (Local_Send);
         POSIX.IO.Close (Local_Receive);
         POSIX.IO.Close (Remote_Send);
         POSIX.IO.Close (Remote_Receive);
         raise;
   end Get_Key;


   function Is_Available return Boolean is
   begin
      return True;
   end Is_Available;

end HMAC.Pinentry;

with "natools";
with "florist";

project Unix_Tools is
   for Source_Dirs use ("tools");
   for Main use ("hmac-md5.ads", "hmac-sha1.ads", "hmac-sha256");

   for Object_Dir use Natools'Object_Dir;
   for Exec_Dir use Natools'Exec_Dir;

   package Compiler is
      for Default_Switches use Natools.Compiler'Default_Switches;
   end Compiler;

   package Linker is
      for Default_Switches use Natools.Linker'Default_Switches;
   end Linker;

   package Naming is
      for Body ("HMAC.Pinentry") use "hmac-pinentry__posix.adb";
   end Naming;
end Unix_Tools;