-----------------------------------------------------------------------
--  security-controllers -- Controllers to verify a security permission
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Security.Contexts;

--  == Security Controller ==
--  The Security.Controllers package defines the security controller used to
--  verify that a given permission is granted.  A security controller uses the security
--  context and other controller specific and internal data to verify that the permission
--  is granted.
--
--  To implement a new security controller, one must:
--

--
Define a type that implements the Controller interface with the
--        Has_Permission operation
--
Write a function to allocate instances of the given Controller type
--
Register the function under a unique name by using Register_Controller
--

--
--  Security controller instances are created when the security policy rules are parsed.
--  These instances are shared accross possibly several concurrent requests.
package Security.Controllers is

   Invalid_Controller : exception;

   --  ------------------------------
   --  Security Controller interface
   --  ------------------------------
   type Controller is limited interface;
   type Controller_Access is access all Controller'Class;

   --  Checks whether the permission defined by the Handler controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Handler : in Controller;
                            Context : in Security.Contexts.Security_Context'Class)
                            return Boolean is abstract;

   type Controller_Factory is not null access function return Controller_Access;

   --  To keep this implementation simple, a maximum of 32 security controller factory
   --  can be registered.  ASF provides one based on roles.  AWA provides another one
   --  based on entity ACLs.
   MAX_CONTROLLER_FACTORY : constant Positive := 32;

   --  Register in a global table the controller factory under the name Name.
   --  When this factory is used, the Factory operation will be called to
   --  create new instances of the controller.
   procedure Register_Controller (Name    : in String;
                                  Factory : in Controller_Factory);

   --  Create a security controller by using the controller factory registered under
   --  the name Name.
   --  Raises Invalid_Controller if the name is not recognized.
   function Create_Controller (Name : in String) return Controller_Access;

end Security.Controllers;

-----------------------------------------------------------------------
--  security-controllers -- Controllers to verify a security permission
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Security.Contexts;

--  == Security Controller ==
--  The Security.Controllers package defines the security controller used to
--  verify that a given permission is granted.  A security controller uses the security
--  context and other controller specific and internal data to verify that the permission
--  is granted.
--
--  To implement a new security controller, one must:
--

--
Define a type that implements the Controller interface with the
--        Has_Permission operation
--
Write a function to allocate instances of the given Controller type
--
Register the function under a unique name by using Register_Controller
--

--
--  Security controller instances are created when the security policy rules are parsed.
--  These instances are shared across possibly several concurrent requests.
package Security.Controllers is

   Invalid_Controller : exception;

   --  ------------------------------
   --  Security Controller interface
   --  ------------------------------
   type Controller is limited interface;
   type Controller_Access is access all Controller'Class;

   --  Checks whether the permission defined by the Handler controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Handler : in Controller;
                            Context : in Security.Contexts.Security_Context'Class)
                            return Boolean is abstract;

   type Controller_Factory is not null access function return Controller_Access;

   --  To keep this implementation simple, a maximum of 32 security controller factory
   --  can be registered.  ASF provides one based on roles.  AWA provides another one
   --  based on entity ACLs.
   MAX_CONTROLLER_FACTORY : constant Positive := 32;

   --  Register in a global table the controller factory under the name Name.
   --  When this factory is used, the Factory operation will be called to
   --  create new instances of the controller.
   procedure Register_Controller (Name    : in String;
                                  Factory : in Controller_Factory);

   --  Create a security controller by using the controller factory registered under
   --  the name Name.
   --  Raises Invalid_Controller if the name is not recognized.
   function Create_Controller (Name : in String) return Controller_Access;

end Security.Controllers;

Fix typo in comment

Fix typo in comment


-----------------------------------------------------------------------
--  util-beans -- Interface Definition with Getter and Setters
--  Copyright (C) 2009, 2010, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  = Ada Beans =
--
--  @include util-beans-objects.ads
--  @include util-beans-objects-datasets.ads
--  @include util-beans-basic.ads
package Util.Beans is

   pragma Preelaborate;

end Util.Beans;

-----------------------------------------------------------------------
--  util-beans -- Interface Definition with Getter and Setters
--  Copyright (C) 2009, 2010, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  = Ada Beans =
--  A [Java Bean](http://en.wikipedia.org/wiki/JavaBean) is an object that
--  allows to access its properties through getters and setters. Java Beans
--  rely on the use of Java introspection to discover the Java Bean object properties.
--
--  An Ada Bean has some similarities with the Java Bean as it tries to expose
--  an object through a set of common interfaces.  Since Ada does not have introspection,
--  some developer work is necessary. The Ada Bean framework consists of:
--
--    * An `Object` concrete type that allows to hold any data type such
--      as boolean, integer, floats, strings, dates and Ada bean objects.
--    * A `Bean` interface that exposes a `Get_Value` and `Set_Value`
--      operation through which the object properties can be obtained and modified.
--    * A `Method_Bean` interface that exposes a set of method bindings
--      that gives access to the methods provided by the Ada Bean object.
--
--  The benefit of Ada beans comes when you need to get a value or invoke
--  a method on an object but you don't know at compile time the object or method.
--  That step being done later through some external configuration or presentation file.
--
--  The Ada Bean framework is the basis for the implementation of
--  [Ada Server Faces](http://code.google.com/p/ada-asf/) and
--  [Ada EL](http://code.google.com/p/ada-el/).  It allows the presentation layer to
--  access information provided by Ada beans.
--
--  @include util-beans-objects.ads
--  @include util-beans-objects-datasets.ads
--  @include util-beans-basic.ads
package Util.Beans is

   pragma Preelaborate;

end Util.Beans;

Integrate some documentation about Ada beans


-------------------------------------------------------------------------------
--   Copyright 2012 Julian Schutsch
--
--   This file is part of ParallelSim
--
--   ParallelSim is free software: you can redistribute it and/or modify
--   it under the terms of the GNU Affero General Public License as published
--   by the Free Software Foundation, either version 3 of the License, or
--   (at your option) any later version.
--
--   ParallelSim 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 Affero General Public License for more details.
--
--   You should have received a copy of the GNU Affero General Public License
--   along with ParallelSim.  If not, see <http://www.gnu.org/licenses/>.
-------------------------------------------------------------------------------

-- Revision History
--   18.Mar 2012 Julian Schutsch
--     - Original version

pragma Ada_2005;

with Interfaces;
with Interfaces.C;
with Interfaces.C.Strings;
with System;
with Ada.Unchecked_Conversion;

package Win32 is

   type UINT_Type is new Interfaces.Unsigned_32;
   type DWORD_Type is new Interfaces.Unsigned_32;
   type HANDLE_Type is new System.Address;
   type HANDLE_Access is access HANDLE_Type;
   type UINT_PTR_Type is new Interfaces.C.ptrdiff_t;
   subtype LONG_PTR_Type is System.Address;
   type LONG_Type is new Interfaces.C.ptrdiff_t;
   subtype ULONG_PTR_Type is System.Address;
   subtype HWND_Type is HANDLE_Type;
   type WPARAM_Type is new Interfaces.C.ptrdiff_t;
   subtype LPARAM_Type is LONG_PTR_Type;
   subtype HINSTANCE_Type is HANDLE_Type;
   subtype HICON_Type is HANDLE_Type;
   subtype HCURSOR_Type is HICON_Type;
   subtype HBRUSH_Type is HANDLE_Type;
   subtype LPCTSTR_Type is Interfaces.C.Strings.chars_ptr;
   type WORD_Type is new Interfaces.Unsigned_16;
   type ATOM_Type is new WORD_Type;
   subtype HMENU_Type is HANDLE_TYPE;
   type LRESULT_Type is new LONG_Type;
   subtype HDC_Type is HANDLE_Type;
   type BOOL_Type is new Interfaces.C.int;
   type BYTE_Type is new Interfaces.Unsigned_8;
   subtype HGLRC_Type is HANDLE_Type;

   function HANDLEToInteger is new Ada.Unchecked_Conversion
     (Source => HANDLE_Type,
      Target => Interfaces.C.ptrdiff_t);

   NULLHANDLE : constant HANDLE_Type:=HANDLE_Type(System.Null_Address);
   TRUE       : constant BOOL_Type:=1;
   FALSE      : constant BOOL_Type:=0;

   function MAKEINTRESOURCE
     (wInteger : WORD_Type)
      return LPCTSTR_Type;
   function GET_X_LPARAM
     (lParam : LPARAM_Type)
      return Integer;
   function GET_Y_LPARAM
     (lParam : LPARAM_Type)
      return Integer;

   function LOWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   function HIWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   CS_HREDRAW : constant UINT_Type:=2;
   CS_VREDRAW : constant UINT_Type:=1;
   CS_OWNDC   : constant UINT_Type:=32;

   WS_OVERLAPPEDWINDOW : constant DWORD_Type:=16#cf0000#;
   WS_CLIPCHILDREN     : constant DWORD_Type:=16#2000000#;
   WS_CLIPSIBLINGS     : constant DWORD_Type:=16#4000000#;
   WS_EX_APPWINDOW     : constant DWORD_Type:=16#40000#;
   WS_EX_CLIENTEDGE    : constant DWORD_Type:=512;

   WM_MOUSELEAVE    : constant := 16#2A3#;
   WM_PAINT         : constant := 15;
   WM_CREATE        : constant := 1;
   WM_SIZE          : constant := 5;
   WM_SIZING        : constant := 532;
   WM_LBUTTONDBLCLK : constant := 515;
   WM_RBUTTONDBLCLK : constant := 518;
   WM_LBUTTONDOWN   : constant := 513;
   WM_LBUTTONUP     : constant := 514;
   WM_RBUTTONDOWN   : constant := 516;
   WM_RBUTTONUP     : constant := 517;
   WM_MOUSEMOVE     : constant := 512;
   WM_DESTROY       : constant := 2;
   WM_ERASEBKGND    : constant := 20;
   WM_KEYDOWN       : constant := 256;
   WM_KEYUP         : constant := 257;
   WM_CHAR          : constant := 258;
   WM_TIMER         : constant := 275;
   WM_QUIT          : constant := 18;

   SW_SHOW : constant := 5;

   PM_NOREMOVE : constant := 0;
   PM_REMOVE   : constant := 1;
   PM_NOYIELD  : constant := 2;

   PFD_DRAW_TO_WINDOW : constant:=4;
   PFD_SUPPORT_OPENGL : constant:=16#20#;
   PFD_TYPE_RGBA      : constant:=0;
   PFD_MAIN_PLANE     : constant:=0;

   IDI_WINLOGO     : constant:=32517;
   IDI_ASTERISK    : constant:=32516;
   IDI_APPLICATION : constant:=32512;
   IDI_ERROR       : constant:=32513;
   IDI_EXCLAMATION : constant:=32515;
   IDC_ARROW       : constant:=32512;

   SW_SHOWNOACTIVATE : constant:=8;

   STILL_ACTIVE : constant DWORD_Type:=259;

   type WNDPROC_Access is
     access function
       (hWnd    : HWND_Type;
        message : UINT_Type;
        wParam  : WPARAM_Type;
        lParam  : LPARAM_Type)
        return LRESULT_Type;
   pragma Convention(C,WNDPROC_Access);

   type WNDCLASS_Type is
      record
         style         : UINT_Type        := 0;
         lpfnWndProc   : WNDPROC_Access   := null;
         cbClsExtra    : Interfaces.C.int := 0;
         cbWndExtra    : Interfaces.C.int := 0;
         hInstance     : HINSTANCE_Type   := Win32.NULLHANDLE;
         hIcon         : HICON_Type       := Win32.NULLHANDLE;
         hCursor       : HCURSOR_Type     := Win32.NULLHANDLE;
         hbrBackground : HBRUSH_Type      := Win32.NULLHANDLE;
         lpszMenuName  : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
         lpszClassName : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
      end record;
   pragma Convention(C,WNDCLASS_Type);

   type CREATESTRUCT_Type is
      record
         lpCreateParams : System.Address:=System.Null_Address;
         hInstance      : HINSTANCE_Type:=Win32.NULLHANDLE;
         hMenu          : HMENU_Type:=Win32.NULLHANDLE;
         hwndParent     : HWND_Type:=Win32.NULLHANDLE;
         cy             : Interfaces.C.int:=0;
         cx             : Interfaces.C.int:=0;
         y              : Interfaces.C.int:=0;
         x              : Interfaces.C.int:=0;
         style          : LONG_Type:=0;
         lpszName       : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         lpszClass      : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         dwExStyle      : DWORD_Type:=0;
      end record;
   type CREATESTRUCT_Access is access CREATESTRUCT_Type;
   pragma Convention(C,CREATESTRUCT_Type);

   type POINT_Type is
      record
         x : LONG_Type;
         y : LONG_Type;
      end record;

   type MSG_Type is
      record
         hwnd    : HWND_Type;
         message : UINT_Type;
         wParam  : UINT_Type;
         lParam  : UINT_Type;
         time    : DWORD_Type;
         pt      : POINT_Type;
      end record;
   pragma Convention(C,MSG_Type);

   HANDLE_FLAG_INHERIT            : constant DWORD_Type:=1;
   HANDLE_FLAG_PROTECT_FROM_CLOSE : constant DWORD_Type:=2;

   type COMMTIMEOUTS_Type is
      record
         ReadIntervalTimeout         : DWORD_Type:=DWORD_Type'Last;
         ReadTotalTimeoutMultiplier  : DWORD_Type:=0;
         ReadTotalTimeoutConstant    : DWORD_Type:=0;
         WriteTotalTimeoutMultiplier : DWORD_Type:=0;
         WriteTotalTimeoutConstant   : DWORD_Type:=0;
      end record;
   pragma Convention(C,COMMTIMEOUTS_Type);

   type SECURITY_ATTRIBUTES_Type is
      record
         nLength              : DWORD_Type;
         lpSecurityDescriptor : System.Address:=System.Null_Address;
         bInheritHandle       : BOOL_Type;
      end record;
   pragma Convention(C,SECURITY_ATTRIBUTES_Type);
   type SECURITY_ATTRIBUTES_Access is access SECURITY_ATTRIBUTES_Type;

   type OVERLAPPED_Type is
      record
         Internal     : ULONG_PTR_Type := System.Null_Address;
         InternalHigh : ULONG_PTR_Type := System.Null_Address;
         Pointer      : System.Address := System.Null_Address;
         hEvent       : HANDLE_Type    := NULLHANDLE;
      end record;
   pragma Convention(C,OVERLAPPED_Type);

   type PIXELFORMATDESCRIPTOR_Type is
      record
         nSize           : WORD_Type  := 0;
         nVersion        : WORD_Type  := 0;
         dwFlags         : DWORD_Type := 0;
         iPixelType      : BYTE_Type  := 0;
         cColorBits      : BYTE_Type  := 0;
         cRedBits        : BYTE_Type  := 0;
         cRedShift       : BYTE_Type  := 0;
         cGreenBits      : BYTE_Type  := 0;
         cGreenShift     : BYTE_Type  := 0;
         cBlueBits       : BYTE_Type  := 0;
         cBlueShift      : BYTE_Type  := 0;
         cAlphaBits      : BYTE_Type  := 0;
         cAlphaShift     : BYTE_Type  := 0;
         cAccumBits      : BYTE_Type  := 0;
         cAccumRedBits   : BYTE_Type  := 0;
         cAccumGreenBits : BYTE_Type  := 0;
         cAccumBlueBits  : BYTE_Type  := 0;
         cAccumAlphaBits : BYTE_Type  := 0;
         cDepthBits      : BYTE_Type  := 0;
         cStencilBits    : BYTE_Type  := 0;
         cAuxBuffers     : BYTE_Type  := 0;
         iLayerType      : BYTE_Type  := 0;
         bReserved       : BYTE_Type  := 0;
         dwLayerMask     : DWORD_Type := 0;
         dwVisibleMask   : DWORD_Type := 0;
         dwDamageMask    : DWORD_Type := 0;
      end record;
   pragma Convention(C,PIXELFORMATDESCRIPTOR_Type);

   type STARTUPINFO_Type is
      record
         cb              : Interfaces.Unsigned_32;
         lpReserved      : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpDesktop       : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpTitle         : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         dwX             : Interfaces.Unsigned_32 := 0;
         dwY             : Interfaces.Unsigned_32 := 0;
         dwXSize         : Interfaces.Unsigned_32 := 0;
         dwYSize         : Interfaces.Unsigned_32 := 0;
         dwXCountChars   : Interfaces.Unsigned_32 := 0;
         dwYCountChars   : Interfaces.Unsigned_32 := 0;
         dwFillAttribute : Interfaces.Unsigned_32 := 0;
         dwFlags         : Interfaces.Unsigned_32 := 0;
         wShowWindow     : Interfaces.Unsigned_16 := 0;
         cbReserved2     : Interfaces.Unsigned_16 := 0;
         hStdInput       : HANDLE_Type            := NULLHANDLE;
         hStdOutput      : HANDLE_Type            := NULLHANDLE;
         hStderr         : HANDLE_Type            := NULLHANDLE;
      end record;
   pragma Convention(C,STARTUPINFO_Type);

   type PROCESS_INFORMATION_Type is
      record
         hProcess    : HANDLE_Type := NULLHANDLE;
         hThread     : HANDLE_Type := NULLHANDLE;
         dwProcessID : Interfaces.Unsigned_32 := 0;
         dwThreadID  : Interfaces.Unsigned_32 := 0;
      end record;
   pragma Convention(C,PROCESS_INFORMATION_Type);

   function GetLastError
     return DWORD_TYPE;
   pragma Import(StdCall,GetLastError,"GetLastError");

   STARTF_USESTDHANDLES : constant:=16#100#;

end Win32;

-------------------------------------------------------------------------------
--   Copyright 2012 Julian Schutsch
--
--   This file is part of ParallelSim
--
--   ParallelSim is free software: you can redistribute it and/or modify
--   it under the terms of the GNU Affero General Public License as published
--   by the Free Software Foundation, either version 3 of the License, or
--   (at your option) any later version.
--
--   ParallelSim 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 Affero General Public License for more details.
--
--   You should have received a copy of the GNU Affero General Public License
--   along with ParallelSim.  If not, see <http://www.gnu.org/licenses/>.
-------------------------------------------------------------------------------

-- Revision History
--   18.Mar 2012 Julian Schutsch
--     - Original version

pragma Ada_2005;

with Interfaces;
with Interfaces.C;
with Interfaces.C.Strings;
with System;
with Ada.Unchecked_Conversion;

package Win32 is
   pragma Linker_Options ("-lgdi32");
   pragma Linker_Options ("-lopengl32");
   pragma Linker_Options ("-lglu32");

   type UINT_Type is new Interfaces.Unsigned_32;
   type DWORD_Type is new Interfaces.Unsigned_32;
   type HANDLE_Type is new System.Address;
   type HANDLE_Access is access HANDLE_Type;
   type UINT_PTR_Type is new Interfaces.C.ptrdiff_t;
   subtype LONG_PTR_Type is System.Address;
   type LONG_Type is new Interfaces.C.ptrdiff_t;
   subtype ULONG_PTR_Type is System.Address;
   subtype HWND_Type is HANDLE_Type;
   type WPARAM_Type is new Interfaces.C.ptrdiff_t;
   subtype LPARAM_Type is LONG_PTR_Type;
   subtype HINSTANCE_Type is HANDLE_Type;
   subtype HICON_Type is HANDLE_Type;
   subtype HCURSOR_Type is HICON_Type;
   subtype HBRUSH_Type is HANDLE_Type;
   subtype LPCTSTR_Type is Interfaces.C.Strings.chars_ptr;
   type WORD_Type is new Interfaces.Unsigned_16;
   type ATOM_Type is new WORD_Type;
   subtype HMENU_Type is HANDLE_TYPE;
   type LRESULT_Type is new LONG_Type;
   subtype HDC_Type is HANDLE_Type;
   type BOOL_Type is new Interfaces.C.int;
   type BYTE_Type is new Interfaces.Unsigned_8;
   subtype HGLRC_Type is HANDLE_Type;

   function HANDLEToInteger is new Ada.Unchecked_Conversion
     (Source => HANDLE_Type,
      Target => Interfaces.C.ptrdiff_t);

   NULLHANDLE : constant HANDLE_Type:=HANDLE_Type(System.Null_Address);
   TRUE       : constant BOOL_Type:=1;
   FALSE      : constant BOOL_Type:=0;

   function MAKEINTRESOURCE
     (wInteger : WORD_Type)
      return LPCTSTR_Type;
   function GET_X_LPARAM
     (lParam : LPARAM_Type)
      return Integer;
   function GET_Y_LPARAM
     (lParam : LPARAM_Type)
      return Integer;

   function LOWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   function HIWORD
     (lParam : LPARAM_Type)
      return WORD_Type;

   CS_HREDRAW : constant UINT_Type:=2;
   CS_VREDRAW : constant UINT_Type:=1;
   CS_OWNDC   : constant UINT_Type:=32;

   WS_OVERLAPPEDWINDOW : constant DWORD_Type:=16#cf0000#;
   WS_CLIPCHILDREN     : constant DWORD_Type:=16#2000000#;
   WS_CLIPSIBLINGS     : constant DWORD_Type:=16#4000000#;
   WS_EX_APPWINDOW     : constant DWORD_Type:=16#40000#;
   WS_EX_CLIENTEDGE    : constant DWORD_Type:=512;

   WM_MOUSELEAVE    : constant := 16#2A3#;
   WM_PAINT         : constant := 15;
   WM_CREATE        : constant := 1;
   WM_SIZE          : constant := 5;
   WM_SIZING        : constant := 532;
   WM_LBUTTONDBLCLK : constant := 515;
   WM_RBUTTONDBLCLK : constant := 518;
   WM_LBUTTONDOWN   : constant := 513;
   WM_LBUTTONUP     : constant := 514;
   WM_RBUTTONDOWN   : constant := 516;
   WM_RBUTTONUP     : constant := 517;
   WM_MOUSEMOVE     : constant := 512;
   WM_DESTROY       : constant := 2;
   WM_ERASEBKGND    : constant := 20;
   WM_KEYDOWN       : constant := 256;
   WM_KEYUP         : constant := 257;
   WM_CHAR          : constant := 258;
   WM_TIMER         : constant := 275;
   WM_QUIT          : constant := 18;

   SW_SHOW : constant := 5;

   PM_NOREMOVE : constant := 0;
   PM_REMOVE   : constant := 1;
   PM_NOYIELD  : constant := 2;

   PFD_DRAW_TO_WINDOW : constant:=4;
   PFD_SUPPORT_OPENGL : constant:=16#20#;
   PFD_TYPE_RGBA      : constant:=0;
   PFD_MAIN_PLANE     : constant:=0;

   IDI_WINLOGO     : constant:=32517;
   IDI_ASTERISK    : constant:=32516;
   IDI_APPLICATION : constant:=32512;
   IDI_ERROR       : constant:=32513;
   IDI_EXCLAMATION : constant:=32515;
   IDC_ARROW       : constant:=32512;

   SW_SHOWNOACTIVATE : constant:=8;

   STILL_ACTIVE : constant DWORD_Type:=259;

   type WNDPROC_Access is
     access function
       (hWnd    : HWND_Type;
        message : UINT_Type;
        wParam  : WPARAM_Type;
        lParam  : LPARAM_Type)
        return LRESULT_Type;
   pragma Convention(C,WNDPROC_Access);

   type WNDCLASS_Type is
      record
         style         : UINT_Type        := 0;
         lpfnWndProc   : WNDPROC_Access   := null;
         cbClsExtra    : Interfaces.C.int := 0;
         cbWndExtra    : Interfaces.C.int := 0;
         hInstance     : HINSTANCE_Type   := Win32.NULLHANDLE;
         hIcon         : HICON_Type       := Win32.NULLHANDLE;
         hCursor       : HCURSOR_Type     := Win32.NULLHANDLE;
         hbrBackground : HBRUSH_Type      := Win32.NULLHANDLE;
         lpszMenuName  : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
         lpszClassName : LPCTSTR_Type     := Interfaces.C.Strings.Null_Ptr;
      end record;
   pragma Convention(C,WNDCLASS_Type);

   type CREATESTRUCT_Type is
      record
         lpCreateParams : System.Address:=System.Null_Address;
         hInstance      : HINSTANCE_Type:=Win32.NULLHANDLE;
         hMenu          : HMENU_Type:=Win32.NULLHANDLE;
         hwndParent     : HWND_Type:=Win32.NULLHANDLE;
         cy             : Interfaces.C.int:=0;
         cx             : Interfaces.C.int:=0;
         y              : Interfaces.C.int:=0;
         x              : Interfaces.C.int:=0;
         style          : LONG_Type:=0;
         lpszName       : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         lpszClass      : LPCTSTR_Type:=Interfaces.C.Strings.Null_Ptr;
         dwExStyle      : DWORD_Type:=0;
      end record;
   type CREATESTRUCT_Access is access CREATESTRUCT_Type;
   pragma Convention(C,CREATESTRUCT_Type);

   type POINT_Type is
      record
         x : LONG_Type;
         y : LONG_Type;
      end record;

   type MSG_Type is
      record
         hwnd    : HWND_Type;
         message : UINT_Type;
         wParam  : UINT_Type;
         lParam  : UINT_Type;
         time    : DWORD_Type;
         pt      : POINT_Type;
      end record;
   pragma Convention(C,MSG_Type);

   HANDLE_FLAG_INHERIT            : constant DWORD_Type:=1;
   HANDLE_FLAG_PROTECT_FROM_CLOSE : constant DWORD_Type:=2;

   type COMMTIMEOUTS_Type is
      record
         ReadIntervalTimeout         : DWORD_Type:=DWORD_Type'Last;
         ReadTotalTimeoutMultiplier  : DWORD_Type:=0;
         ReadTotalTimeoutConstant    : DWORD_Type:=0;
         WriteTotalTimeoutMultiplier : DWORD_Type:=0;
         WriteTotalTimeoutConstant   : DWORD_Type:=0;
      end record;
   pragma Convention(C,COMMTIMEOUTS_Type);

   type SECURITY_ATTRIBUTES_Type is
      record
         nLength              : DWORD_Type;
         lpSecurityDescriptor : System.Address:=System.Null_Address;
         bInheritHandle       : BOOL_Type;
      end record;
   pragma Convention(C,SECURITY_ATTRIBUTES_Type);
   type SECURITY_ATTRIBUTES_Access is access SECURITY_ATTRIBUTES_Type;

   type OVERLAPPED_Type is
      record
         Internal     : ULONG_PTR_Type := System.Null_Address;
         InternalHigh : ULONG_PTR_Type := System.Null_Address;
         Pointer      : System.Address := System.Null_Address;
         hEvent       : HANDLE_Type    := NULLHANDLE;
      end record;
   pragma Convention(C,OVERLAPPED_Type);

   type PIXELFORMATDESCRIPTOR_Type is
      record
         nSize           : WORD_Type  := 0;
         nVersion        : WORD_Type  := 0;
         dwFlags         : DWORD_Type := 0;
         iPixelType      : BYTE_Type  := 0;
         cColorBits      : BYTE_Type  := 0;
         cRedBits        : BYTE_Type  := 0;
         cRedShift       : BYTE_Type  := 0;
         cGreenBits      : BYTE_Type  := 0;
         cGreenShift     : BYTE_Type  := 0;
         cBlueBits       : BYTE_Type  := 0;
         cBlueShift      : BYTE_Type  := 0;
         cAlphaBits      : BYTE_Type  := 0;
         cAlphaShift     : BYTE_Type  := 0;
         cAccumBits      : BYTE_Type  := 0;
         cAccumRedBits   : BYTE_Type  := 0;
         cAccumGreenBits : BYTE_Type  := 0;
         cAccumBlueBits  : BYTE_Type  := 0;
         cAccumAlphaBits : BYTE_Type  := 0;
         cDepthBits      : BYTE_Type  := 0;
         cStencilBits    : BYTE_Type  := 0;
         cAuxBuffers     : BYTE_Type  := 0;
         iLayerType      : BYTE_Type  := 0;
         bReserved       : BYTE_Type  := 0;
         dwLayerMask     : DWORD_Type := 0;
         dwVisibleMask   : DWORD_Type := 0;
         dwDamageMask    : DWORD_Type := 0;
      end record;
   pragma Convention(C,PIXELFORMATDESCRIPTOR_Type);

   type STARTUPINFO_Type is
      record
         cb              : Interfaces.Unsigned_32;
         lpReserved      : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpDesktop       : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         lpTitle         : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.Null_Ptr;
         dwX             : Interfaces.Unsigned_32 := 0;
         dwY             : Interfaces.Unsigned_32 := 0;
         dwXSize         : Interfaces.Unsigned_32 := 0;
         dwYSize         : Interfaces.Unsigned_32 := 0;
         dwXCountChars   : Interfaces.Unsigned_32 := 0;
         dwYCountChars   : Interfaces.Unsigned_32 := 0;
         dwFillAttribute : Interfaces.Unsigned_32 := 0;
         dwFlags         : Interfaces.Unsigned_32 := 0;
         wShowWindow     : Interfaces.Unsigned_16 := 0;
         cbReserved2     : Interfaces.Unsigned_16 := 0;
         hStdInput       : HANDLE_Type            := NULLHANDLE;
         hStdOutput      : HANDLE_Type            := NULLHANDLE;
         hStderr         : HANDLE_Type            := NULLHANDLE;
      end record;
   pragma Convention(C,STARTUPINFO_Type);

   type PROCESS_INFORMATION_Type is
      record
         hProcess    : HANDLE_Type := NULLHANDLE;
         hThread     : HANDLE_Type := NULLHANDLE;
         dwProcessID : Interfaces.Unsigned_32 := 0;
         dwThreadID  : Interfaces.Unsigned_32 := 0;
      end record;
   pragma Convention(C,PROCESS_INFORMATION_Type);

   function GetLastError
     return DWORD_TYPE;
   pragma Import(StdCall,GetLastError,"GetLastError");

   STARTF_USESTDHANDLES : constant:=16#100#;

end Win32;

add linker_options pragmas for opengl/win

adding them to package library in the project file doesnt seem to work.


with C_String.Arrays;
with C_String;
with Interfaces.C;
with System.Address_To_Access_Conversions;

package body Jack.Client is
  package C renames Interfaces.C;

  use type C.int;
  use type Port_Name_t;
  use type System.Address;
  use type Thin.Port_Flags_t;
  use type Thin.Status_t;

  --
  -- Activate
  --

  procedure Activate
    (Client : in     Client_t;
     Failed :    out Boolean)
  is
    C_Return : constant C.int := Thin.Activate (System.Address (Client));
  begin
    Failed := C_Return /= 0;
  end Activate;

  --
  -- Close
  --

  procedure Close
    (Client : in     Client_t;
     Failed :    out Boolean) is
  begin
    Failed := Thin.Client_Close (System.Address (Client)) /= 0;
  end Close;

  --
  -- Compare
  --

  function Compare
    (Left  : in Client_t;
     Right : in Client_t) return Boolean is
  begin
    return System.Address (Left) = System.Address (Right);
  end Compare;

  function Compare
    (Left  : in Port_t;
     Right : in Port_t) return Boolean is
  begin
    return System.Address (Left) = System.Address (Right);
  end Compare;

  --
  -- Connect
  --

  procedure Connect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean)
  is
    C_Source : aliased C.char_array := C.To_C (Port_Names.To_String (Source_Port));
    C_Dest   : aliased C.char_array := C.To_C (Port_Names.To_String (Destination_Port));
    C_Result : constant C.int       := Thin.Connect
      (Client           => System.Address (Client),
       Source_Port      => C_String.To_C_String (C_Source'Unchecked_Access),
       Destination_Port => C_String.To_C_String (C_Dest'Unchecked_Access));
  begin
    Failed := C_Result /= 0;
  end Connect;

  --
  -- Disconnect
  --

  procedure Disconnect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean)
  is
    C_Source : aliased C.char_array := C.To_C (Port_Names.To_String (Source_Port));
    C_Dest   : aliased C.char_array := C.To_C (Port_Names.To_String (Destination_Port));
    C_Result : constant C.int       := Thin.Disconnect
      (Client           => System.Address (Client),
       Source_Port      => C_String.To_C_String (C_Source'Unchecked_Access),
       Destination_Port => C_String.To_C_String (C_Dest'Unchecked_Access));
  begin
    Failed := C_Result /= 0;
  end Disconnect;

  --
  -- Get_Ports
  --

  procedure Get_Ports_Free (Data : System.Address);
  pragma Import (C, Get_Ports_Free, "jack_ada_client_get_ports_free");

  procedure Get_Ports
    (Client            : in     Client_t;
     Port_Name_Pattern : in     String           := "";
     Port_Type_Pattern : in     String           := "";
     Port_Flags        : in     Port_Flags_t     := (others => False);
     Ports             :    out Port_Name_Set_t)
  is
    Name     : Port_Name_t;
    Size     : Natural;
    C_Flags  : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name   : aliased C.char_array       := C.To_C (Port_Name_Pattern);
    C_Type   : aliased C.char_array       := C.To_C (Port_Type_Pattern);
    Ptr_Name : C_String.String_Ptr_t;
    Ptr_Type : C_String.String_Ptr_t;
    Address  : C_String.Arrays.Pointer_Array_t;
  begin
    if Port_Name_Pattern /= Port_Names.Null_Bounded_String then
      Ptr_Name := C_String.To_C_String (C_Name'Unchecked_Access);
    end if;
    if Port_Type_Pattern /= "" then
      Ptr_Type := C_String.To_C_String (C_Type'Unchecked_Access);
    end if;

    Address := Thin.Get_Ports
     (Client            => System.Address (Client),
      Port_Name_Pattern => Ptr_Name,
      Type_Name_Pattern => Ptr_Type,
      Flags             => C_Flags);

    Size := C_String.Arrays.Size_Terminated (Address);

    for Index in 0 .. Size loop
      Port_Names.Set_Bounded_String
        (Source => C_String.Arrays.Index_Terminated (Address, Index),
         Target => Name);
      Port_Name_Sets.Insert (Ports, Name);
    end loop;

    -- The strings returned by jack_get_ports are heap allocated.
    Get_Ports_Free (System.Address (Address));
  end Get_Ports;

  --
  -- Status, option and flag mapping.
  --

  type Status_Map_t is array (Status_Selector_t) of Thin.Status_t;

  Status_Map : constant Status_Map_t := Status_Map_t'
    (Failure               => Thin.JackFailure,
     Invalid_Option        => Thin.JackInvalidOption,
     Name_Not_Unique       => Thin.JackNameNotUnique,
     Server_Started        => Thin.JackServerStarted,
     Server_Failed         => Thin.JackServerFailed,
     Server_Error          => Thin.JackServerError,
     No_Such_Client        => Thin.JackNoSuchClient,
     Load_Failure          => Thin.JackLoadFailure,
     Init_Failure          => Thin.JackInitFailure,
     Shared_Memory_Failure => Thin.JackShmFailure,
     Version_Error         => Thin.JackVersionError);

  type Options_Map_t is array (Option_Selector_t) of Thin.Options_t;

  Options_Map : constant Options_Map_t := Options_Map_t'
    (Do_Not_Start_Server => Thin.JackNoStartServer,
     Use_Exact_Name      => Thin.JackUseExactName,
     Server_Name         => Thin.JackServerName,
     Load_Name           => Thin.JackLoadName,
     Load_Initialize     => Thin.JackLoadInit);

  type Port_Flags_Map_t is array (Port_Flag_Selector_t) of Thin.Port_Flags_t;

  Port_Flags_Map : constant Port_Flags_Map_t := Port_Flags_Map_t'
    (Port_Is_Input    => Thin.JackPortIsInput,
     Port_Is_Output   => Thin.JackPortIsOutput,
     Port_Is_Physical => Thin.JackPortIsPhysical,
     Port_Can_Monitor => Thin.JackPortCanMonitor,
     Port_Is_Terminal => Thin.JackPortIsTerminal);

  function Map_Options_To_Thin (Options : Options_t) return Thin.Options_t is
    Return_Options : Thin.Options_t := 0;
  begin
    for Selector in Options_t'Range loop
      if Options (Selector) then
        Return_Options := Return_Options or Options_Map (Selector);
      end if;
    end loop;
    return Return_Options;
  end Map_Options_To_Thin;

  function Map_Port_Flags_To_Thin (Port_Flags : Port_Flags_t) return Thin.Port_Flags_t is
    Return_Port_Flags : Thin.Port_Flags_t := 0;
  begin
    for Selector in Port_Flags_t'Range loop
      if Port_Flags (Selector) then
        Return_Port_Flags := Return_Port_Flags or Port_Flags_Map (Selector);
      end if;
    end loop;
    return Return_Port_Flags;
  end Map_Port_Flags_To_Thin;

  function Map_Status_To_Thin (Status : Status_t) return Thin.Status_t is
    Return_Status : Thin.Status_t := 0;
  begin
    for Selector in Status_t'Range loop
      if Status (Selector) then
        Return_Status := Return_Status or Status_Map (Selector);
      end if;
    end loop;
    return Return_Status;
  end Map_Status_To_Thin;

  function Map_Thin_To_Options (Options : Thin.Options_t) return Options_t is
    Return_Options : Options_t := (others => False);
  begin
    for Selector in Options_t'Range loop
      Return_Options (Selector) :=
        (Options and Options_Map (Selector)) = Options_Map (Selector);
    end loop;
    return Return_Options;
  end Map_Thin_To_Options;

  function Map_Thin_To_Port_Flags (Port_Flags : Thin.Port_Flags_t) return Port_Flags_t is
    Return_Port_Flags : Port_Flags_t := (others => False);
  begin
    for Selector in Port_Flags_t'Range loop
      Return_Port_Flags (Selector) :=
        (Port_Flags and Port_Flags_Map (Selector)) = Port_Flags_Map (Selector);
    end loop;
    return Return_Port_Flags;
  end Map_Thin_To_Port_Flags;

  function Map_Thin_To_Status (Status : Thin.Status_t) return Status_t is
    Return_Status : Status_t := (others => False);
  begin
    for Selector in Status_t'Range loop
      Return_Status (Selector) :=
        (Status and Status_Map (Selector)) = Status_Map (Selector);
    end loop;
    return Return_Status;
  end Map_Thin_To_Status;

  --
  -- Open
  --

  procedure Open
    (Client_Name : in     String;
     Options     : in     Options_t;
     Client      :    out Client_t;
     Status      : in out Status_t)
  is
    function C_Client_Open
      (Client_Name : C_String.String_Not_Null_Ptr_t;
       Options     : Thin.Options_t;
       Status      : System.Address) return System.Address;
    pragma Import (C, C_Client_Open, "jack_ada_client_open");

    C_Client  : System.Address;
    C_Name    : aliased C.char_array    := C.To_C (Client_Name);
    C_Options : constant Thin.Options_t := Map_Options_To_Thin (Options);
    C_Status  : aliased Thin.Status_t   := 0;
  begin
    pragma Assert (Client_Name /= "");

    C_Client := C_Client_Open
      (Client_Name => C_String.To_C_String (C_Name'Unchecked_Access),
       Options     => C_Options,
       Status      => C_Status'Address);
    Status := Map_Thin_To_Status (C_Status);

    if C_Client = System.Null_Address then
      Client := Invalid_Client;
    else
      Client := Client_t (C_Client);
    end if;
  end Open;

  --
  -- Port_Register
  --

  procedure Port_Register
    (Client      : in     Client_t;
     Port        :    out Port_t;
     Port_Name   : in     Port_Name_t;
     Port_Type   : in     String       := Default_Audio_Type;
     Port_Flags  : in     Port_Flags_t := (others => False);
     Buffer_Size : in     Natural      := 0)
  is
    C_Flags  : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name   : aliased C.char_array       := C.To_C (Port_Names.To_String (Port_Name));
    C_Port   : System.Address;
    C_Type   : aliased C.char_array       := C.To_C (Port_Type);
  begin
    C_Port := Thin.Port_Register
      (Client      => System.Address (Client),
       Port_Name   => C_String.To_C_String (C_Name'Unchecked_Access),
       Port_Type   => C_String.To_C_String (C_Type'Unchecked_Access),
       Flags       => C_Flags,
       Buffer_Size => C.unsigned_long (Buffer_Size));

    if C_Port = System.Null_Address then
      Port := Invalid_Port;
    else
      Port := Port_t (C_Port);
    end if;
  end Port_Register;

  --
  -- Generic_Callbacks
  --

  package body Generic_Callbacks is

    package Convert_Process is new
      System.Address_To_Access_Conversions (Process_Callback_State_t);

    function C_Set_Process_Callback
      (Client   : System.Address;
       Callback : access procedure
        (Number_Of_Frames : Thin.Number_Of_Frames_t;
         Data             : System.Address);
       Data     : System.Address) return Thin.Integer_t;
    pragma Import (C, C_Set_Process_Callback, "jack_set_process_callback");

    procedure Process_Callback_Inner
      (Number_Of_Frames : Thin.Number_Of_Frames_t;
       Data             : System.Address)
    is
      State : Process_Callback_State_t;
      for State'Address use Data;
      pragma Import (Ada, State);
    begin
      State.Callback
        (Number_Of_Frames => Number_Of_Frames_t (Number_Of_Frames),
         User_Data        => State.User_Data);
    end Process_Callback_Inner;

    procedure Set_Process_Callback
      (Client    : in     Client_t;
       State     : in     Process_Callback_State_Access_t;
       Failed    :    out Boolean)
    is
      Pointer : constant Convert_Process.Object_Pointer :=
        Convert_Process.Object_Pointer (State);
    begin
      Failed := 0 /= C_Set_Process_Callback
        (Client   => System.Address (Client),
         Callback => Process_Callback_Inner'Access,
         Data     => Convert_Process.To_Address (Pointer));
    end Set_Process_Callback;

  end Generic_Callbacks;

  --
  -- To_Address
  --

  function To_Address (Client : in Client_t) return System.Address is
  begin
    return System.Address (Client);
  end To_Address;

  function To_Address (Port : in Port_t) return System.Address is
  begin
    return System.Address (Port);
  end To_Address;

end Jack.Client;

with C_String.Arrays;
with C_String;
with Interfaces.C;
with System.Address_To_Access_Conversions;

package body Jack.Client is
  package C renames Interfaces.C;

  use type C.int;
  use type Port_Name_t;
  use type System.Address;
  use type Thin.Port_Flags_t;
  use type Thin.Status_t;

  --
  -- Activate
  --

  procedure Activate
    (Client : in     Client_t;
     Failed :    out Boolean)
  is
    C_Return : constant C.int := Thin.Activate (System.Address (Client));
  begin
    Failed := C_Return /= 0;
  end Activate;

  --
  -- Close
  --

  procedure Close
    (Client : in     Client_t;
     Failed :    out Boolean) is
  begin
    Failed := Thin.Client_Close (System.Address (Client)) /= 0;
  end Close;

  --
  -- Compare
  --

  function Compare
    (Left  : in Client_t;
     Right : in Client_t) return Boolean is
  begin
    return System.Address (Left) = System.Address (Right);
  end Compare;

  function Compare
    (Left  : in Port_t;
     Right : in Port_t) return Boolean is
  begin
    return System.Address (Left) = System.Address (Right);
  end Compare;

  --
  -- Connect
  --

  procedure Connect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean)
  is
    C_Source : aliased C.char_array := C.To_C (Port_Names.To_String (Source_Port));
    C_Dest   : aliased C.char_array := C.To_C (Port_Names.To_String (Destination_Port));
    C_Result : constant C.int       := Thin.Connect
      (Client           => System.Address (Client),
       Source_Port      => C_String.To_C_String (C_Source'Unchecked_Access),
       Destination_Port => C_String.To_C_String (C_Dest'Unchecked_Access));
  begin
    Failed := C_Result /= 0;
  end Connect;

  --
  -- Disconnect
  --

  procedure Disconnect
    (Client           : in     Client_t;
     Source_Port      : in     Port_Name_t;
     Destination_Port : in     Port_Name_t;
     Failed           :    out Boolean)
  is
    C_Source : aliased C.char_array := C.To_C (Port_Names.To_String (Source_Port));
    C_Dest   : aliased C.char_array := C.To_C (Port_Names.To_String (Destination_Port));
    C_Result : constant C.int       := Thin.Disconnect
      (Client           => System.Address (Client),
       Source_Port      => C_String.To_C_String (C_Source'Unchecked_Access),
       Destination_Port => C_String.To_C_String (C_Dest'Unchecked_Access));
  begin
    Failed := C_Result /= 0;
  end Disconnect;

  --
  -- Get_Ports
  --

  procedure Get_Ports_Free (Data : System.Address);
  pragma Import (C, Get_Ports_Free, "jack_ada_client_get_ports_free");

  procedure Get_Ports
    (Client            : in     Client_t;
     Port_Name_Pattern : in     String           := "";
     Port_Type_Pattern : in     String           := "";
     Port_Flags        : in     Port_Flags_t     := (others => False);
     Ports             :    out Port_Name_Set_t)
  is
    Name     : Port_Name_t;
    Size     : Natural;
    C_Flags  : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name   : aliased C.char_array       := C.To_C (Port_Name_Pattern);
    C_Type   : aliased C.char_array       := C.To_C (Port_Type_Pattern);
    Ptr_Name : C_String.String_Ptr_t;
    Ptr_Type : C_String.String_Ptr_t;
    Address  : C_String.Arrays.Pointer_Array_t;
  begin
    if Port_Name_Pattern /= Port_Names.Null_Bounded_String then
      Ptr_Name := C_String.To_C_String (C_Name'Unchecked_Access);
    end if;
    if Port_Type_Pattern /= "" then
      Ptr_Type := C_String.To_C_String (C_Type'Unchecked_Access);
    end if;

    Address := Thin.Get_Ports
     (Client            => System.Address (Client),
      Port_Name_Pattern => Ptr_Name,
      Type_Name_Pattern => Ptr_Type,
      Flags             => C_Flags);

    if Address /= System.Null_Address then
      Size := C_String.Arrays.Size_Terminated (Address);
      if Size > 0 then
        for Index in 0 .. Size - 1 loop
          Port_Names.Set_Bounded_String
            (Source => C_String.Arrays.Index_Terminated (Address, Index),
             Target => Name);
          Port_Name_Sets.Insert (Ports, Name);
        end loop;
      end if;

      -- The strings returned by jack_get_ports are heap allocated.
      Get_Ports_Free (System.Address (Address));
    end if;
  end Get_Ports;

  --
  -- Status, option and flag mapping.
  --

  type Status_Map_t is array (Status_Selector_t) of Thin.Status_t;

  Status_Map : constant Status_Map_t := Status_Map_t'
    (Failure               => Thin.JackFailure,
     Invalid_Option        => Thin.JackInvalidOption,
     Name_Not_Unique       => Thin.JackNameNotUnique,
     Server_Started        => Thin.JackServerStarted,
     Server_Failed         => Thin.JackServerFailed,
     Server_Error          => Thin.JackServerError,
     No_Such_Client        => Thin.JackNoSuchClient,
     Load_Failure          => Thin.JackLoadFailure,
     Init_Failure          => Thin.JackInitFailure,
     Shared_Memory_Failure => Thin.JackShmFailure,
     Version_Error         => Thin.JackVersionError);

  type Options_Map_t is array (Option_Selector_t) of Thin.Options_t;

  Options_Map : constant Options_Map_t := Options_Map_t'
    (Do_Not_Start_Server => Thin.JackNoStartServer,
     Use_Exact_Name      => Thin.JackUseExactName,
     Server_Name         => Thin.JackServerName,
     Load_Name           => Thin.JackLoadName,
     Load_Initialize     => Thin.JackLoadInit);

  type Port_Flags_Map_t is array (Port_Flag_Selector_t) of Thin.Port_Flags_t;

  Port_Flags_Map : constant Port_Flags_Map_t := Port_Flags_Map_t'
    (Port_Is_Input    => Thin.JackPortIsInput,
     Port_Is_Output   => Thin.JackPortIsOutput,
     Port_Is_Physical => Thin.JackPortIsPhysical,
     Port_Can_Monitor => Thin.JackPortCanMonitor,
     Port_Is_Terminal => Thin.JackPortIsTerminal);

  function Map_Options_To_Thin (Options : Options_t) return Thin.Options_t is
    Return_Options : Thin.Options_t := 0;
  begin
    for Selector in Options_t'Range loop
      if Options (Selector) then
        Return_Options := Return_Options or Options_Map (Selector);
      end if;
    end loop;
    return Return_Options;
  end Map_Options_To_Thin;

  function Map_Port_Flags_To_Thin (Port_Flags : Port_Flags_t) return Thin.Port_Flags_t is
    Return_Port_Flags : Thin.Port_Flags_t := 0;
  begin
    for Selector in Port_Flags_t'Range loop
      if Port_Flags (Selector) then
        Return_Port_Flags := Return_Port_Flags or Port_Flags_Map (Selector);
      end if;
    end loop;
    return Return_Port_Flags;
  end Map_Port_Flags_To_Thin;

  function Map_Status_To_Thin (Status : Status_t) return Thin.Status_t is
    Return_Status : Thin.Status_t := 0;
  begin
    for Selector in Status_t'Range loop
      if Status (Selector) then
        Return_Status := Return_Status or Status_Map (Selector);
      end if;
    end loop;
    return Return_Status;
  end Map_Status_To_Thin;

  function Map_Thin_To_Options (Options : Thin.Options_t) return Options_t is
    Return_Options : Options_t := (others => False);
  begin
    for Selector in Options_t'Range loop
      Return_Options (Selector) :=
        (Options and Options_Map (Selector)) = Options_Map (Selector);
    end loop;
    return Return_Options;
  end Map_Thin_To_Options;

  function Map_Thin_To_Port_Flags (Port_Flags : Thin.Port_Flags_t) return Port_Flags_t is
    Return_Port_Flags : Port_Flags_t := (others => False);
  begin
    for Selector in Port_Flags_t'Range loop
      Return_Port_Flags (Selector) :=
        (Port_Flags and Port_Flags_Map (Selector)) = Port_Flags_Map (Selector);
    end loop;
    return Return_Port_Flags;
  end Map_Thin_To_Port_Flags;

  function Map_Thin_To_Status (Status : Thin.Status_t) return Status_t is
    Return_Status : Status_t := (others => False);
  begin
    for Selector in Status_t'Range loop
      Return_Status (Selector) :=
        (Status and Status_Map (Selector)) = Status_Map (Selector);
    end loop;
    return Return_Status;
  end Map_Thin_To_Status;

  --
  -- Open
  --

  procedure Open
    (Client_Name : in     String;
     Options     : in     Options_t;
     Client      :    out Client_t;
     Status      : in out Status_t)
  is
    function C_Client_Open
      (Client_Name : C_String.String_Not_Null_Ptr_t;
       Options     : Thin.Options_t;
       Status      : System.Address) return System.Address;
    pragma Import (C, C_Client_Open, "jack_ada_client_open");

    C_Client  : System.Address;
    C_Name    : aliased C.char_array    := C.To_C (Client_Name);
    C_Options : constant Thin.Options_t := Map_Options_To_Thin (Options);
    C_Status  : aliased Thin.Status_t   := 0;
  begin
    pragma Assert (Client_Name /= "");

    C_Client := C_Client_Open
      (Client_Name => C_String.To_C_String (C_Name'Unchecked_Access),
       Options     => C_Options,
       Status      => C_Status'Address);
    Status := Map_Thin_To_Status (C_Status);

    if C_Client = System.Null_Address then
      Client := Invalid_Client;
    else
      Client := Client_t (C_Client);
    end if;
  end Open;

  --
  -- Port_Register
  --

  procedure Port_Register
    (Client      : in     Client_t;
     Port        :    out Port_t;
     Port_Name   : in     Port_Name_t;
     Port_Type   : in     String       := Default_Audio_Type;
     Port_Flags  : in     Port_Flags_t := (others => False);
     Buffer_Size : in     Natural      := 0)
  is
    C_Flags  : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name   : aliased C.char_array       := C.To_C (Port_Names.To_String (Port_Name));
    C_Port   : System.Address;
    C_Type   : aliased C.char_array       := C.To_C (Port_Type);
  begin
    C_Port := Thin.Port_Register
      (Client      => System.Address (Client),
       Port_Name   => C_String.To_C_String (C_Name'Unchecked_Access),
       Port_Type   => C_String.To_C_String (C_Type'Unchecked_Access),
       Flags       => C_Flags,
       Buffer_Size => C.unsigned_long (Buffer_Size));

    if C_Port = System.Null_Address then
      Port := Invalid_Port;
    else
      Port := Port_t (C_Port);
    end if;
  end Port_Register;

  --
  -- Generic_Callbacks
  --

  package body Generic_Callbacks is

    package Convert_Process is new
      System.Address_To_Access_Conversions (Process_Callback_State_t);

    function C_Set_Process_Callback
      (Client   : System.Address;
       Callback : access procedure
        (Number_Of_Frames : Thin.Number_Of_Frames_t;
         Data             : System.Address);
       Data     : System.Address) return Thin.Integer_t;
    pragma Import (C, C_Set_Process_Callback, "jack_set_process_callback");

    procedure Process_Callback_Inner
      (Number_Of_Frames : Thin.Number_Of_Frames_t;
       Data             : System.Address)
    is
      State : Process_Callback_State_t;
      for State'Address use Data;
      pragma Import (Ada, State);
    begin
      State.Callback
        (Number_Of_Frames => Number_Of_Frames_t (Number_Of_Frames),
         User_Data        => State.User_Data);
    end Process_Callback_Inner;

    procedure Set_Process_Callback
      (Client    : in     Client_t;
       State     : in     Process_Callback_State_Access_t;
       Failed    :    out Boolean)
    is
      Pointer : constant Convert_Process.Object_Pointer :=
        Convert_Process.Object_Pointer (State);
    begin
      Failed := 0 /= C_Set_Process_Callback
        (Client   => System.Address (Client),
         Callback => Process_Callback_Inner'Access,
         Data     => Convert_Process.To_Address (Pointer));
    end Set_Process_Callback;

  end Generic_Callbacks;

  --
  -- To_Address
  --

  function To_Address (Client : in Client_t) return System.Address is
  begin
    return System.Address (Client);
  end To_Address;

  function To_Address (Port : in Port_t) return System.Address is
  begin
    return System.Address (Port);
  end To_Address;

end Jack.Client;

Check NULL return, correct use of Size

Check NULL return, correct use of Size


with HAL;           use HAL;
with Virtual_File_System; use Virtual_File_System;
with HAL.Filesystem; use HAL.Filesystem;
with Semihosting;
with Semihosting.Filesystem; use Semihosting.Filesystem;

procedure Main is

   procedure List_Dir (FS : in out FS_Driver'Class; Path : Pathname);

   procedure List_Dir (FS : in out FS_Driver'Class; Path : Pathname) is
      Status : Status_Kind;
      DH : Directory_Handle_Ref;
   begin
      Status := FS.Open_Directory (Path, DH);
      if Status /= Status_Ok then
         Semihosting.Log_Line ("Open Directory '" & Path & "' Error: " & Status'Img);
      else
         declare
            Ent : Directory_Entry;
            Index : Positive := 1;
         begin

            Semihosting.Log_Line ("Listing '" & Path & "' content:");
            loop
               Status := DH.Read_Entry (Index, Ent);
               if Status = Status_Ok then
                  Semihosting.Log_Line (" - '" & DH.Entry_Name (Index) & "'");
                  Semihosting.Log_Line ("   Kind: " & Ent.Entry_Type'Img);
               else
                  exit;
               end if;
               Index := Index + 1;
            end loop;
         end;
      end if;
   end List_Dir;

   My_VFS : VFS;
   My_VFS2 : aliased VFS;
   My_VFS3 : aliased VFS;
   My_SHFS : aliased SHFS;
   Status : Status_Kind;
   FH : File_Handle_Ref;
   Data : Byte_Array (1 .. 10);

begin

   Status := My_VFS.Mount (Path       => "test1",
                           Filesystem => My_VFS2'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;
   Status := My_VFS2.Mount (Path       => "test2",
                            Filesystem => My_VFS3'Unchecked_Access);

   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Mount (Path       => "host",
                            Filesystem => My_SHFS'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Unlink ("/test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("//test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1//no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1/test2/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;

   Status := My_VFS.Open ("/host/tmp/test.shfs", FH);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Open Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Seek (10);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Seek Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Close;
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Close Error: " & Status'Img);
   end if;

   List_Dir (My_VFS, "/");
   List_Dir (My_VFS, "/test1");
   List_Dir (My_VFS, "/test1/");
end Main;

with HAL;           use HAL;
with Virtual_File_System; use Virtual_File_System;
with HAL.Filesystem; use HAL.Filesystem;
with Semihosting;
with Semihosting.Filesystem; use Semihosting.Filesystem;
with File_Block_Drivers; use File_Block_Drivers;
with Partitions; use Partitions;

procedure Main is

   procedure List_Dir (FS : in out FS_Driver'Class;
                       Path : Pathname);
   procedure List_Partitions (FS : in out FS_Driver'Class;
                              Path_To_Disk_Image : Pathname);

   --------------
   -- List_Dir --
   --------------

   procedure List_Dir (FS : in out FS_Driver'Class; Path : Pathname) is
      Status : Status_Kind;
      DH : Directory_Handle_Ref;
   begin
      Status := FS.Open_Directory (Path, DH);
      if Status /= Status_Ok then
         Semihosting.Log_Line ("Open Directory '" & Path & "' Error: " & Status'Img);
      else
         declare
            Ent : Directory_Entry;
            Index : Positive := 1;
         begin

            Semihosting.Log_Line ("Listing '" & Path & "' content:");
            loop
               Status := DH.Read_Entry (Index, Ent);
               if Status = Status_Ok then
                  Semihosting.Log_Line (" - '" & DH.Entry_Name (Index) & "'");
                  Semihosting.Log_Line ("   Kind: " & Ent.Entry_Type'Img);
               else
                  exit;
               end if;
               Index := Index + 1;
            end loop;
         end;
      end if;
   end List_Dir;

   ---------------------
   -- List_Partitions --
   ---------------------

   procedure List_Partitions (FS : in out FS_Driver'Class;
                              Path_To_Disk_Image : Pathname)
   is
      File : File_Handle_Ref;
   begin
      if FS.Open (Path_To_Disk_Image, File) /= Status_Ok then
         Semihosting.Log_Line ("Cannot open disk image '" &
                                 Path_To_Disk_Image & "'");
         return;
      end if;

      declare
         Disk    : aliased File_Block_Driver (File);
         Nbr     : Natural;
         P_Entry : Partition_Entry;
      begin
         Nbr := Number_Of_Partitions (Disk'Unchecked_Access);
         Semihosting.Log_Line ("Disk '" & Path_To_Disk_Image & "' has " &
                                 Nbr'Img & " parition(s)");

         for Id in 1 .. Nbr loop
            if Get_Partition_Entry (Disk'Unchecked_Access,
                                    Id,
                                    P_Entry) /= Status_Ok
            then
               Semihosting.Log_Line ("Cannot read partition :" & Id'Img);
            else
               Semihosting.Log_Line (" - partition :" & Id'Img);
               Semihosting.Log_Line ("      Status:" & P_Entry.Status'Img);
               Semihosting.Log_Line ("      Kind: " & P_Entry.Kind'Img);
               Semihosting.Log_Line ("      LBA: " & P_Entry.First_Sector_LBA'Img);
               Semihosting.Log_Line ("      Number of sectors: " & P_Entry.Number_Of_Sectors'Img);

            end if;
         end loop;
      end;
   end List_Partitions;

   My_VFS : VFS;
   My_VFS2 : aliased VFS;
   My_VFS3 : aliased VFS;
   My_SHFS : aliased SHFS;
   Status : Status_Kind;
   FH : File_Handle_Ref;
   Data : Byte_Array (1 .. 10);

begin

   Status := My_VFS.Mount (Path       => "test1",
                           Filesystem => My_VFS2'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;
   Status := My_VFS2.Mount (Path       => "test2",
                            Filesystem => My_VFS3'Unchecked_Access);

   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   Status := My_VFS.Mount (Path       => "host",
                            Filesystem => My_SHFS'Unchecked_Access);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Mount Error: " & Status'Img);
   end if;

   List_Partitions (My_VFS, "/host/tmp/disk.img");

   Status := My_VFS.Unlink ("/test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("//test1/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1//no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;
   Status := My_VFS.Unlink ("/test1/test2/no_file");
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Unlink Error: " & Status'Img);
   end if;

   Status := My_VFS.Open ("/host/tmp/test.shfs", FH);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Open Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Seek (10);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Seek Error: " & Status'Img);
   end if;

   Status := FH.Read (Data);
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Read Error: " & Status'Img);
   end if;

   for C of Data loop
      Semihosting.Log (Character'Val (Integer (C)));
   end loop;
   Semihosting.Log_New_Line;

   Status := FH.Close;
   if Status /= Status_Ok then
      Semihosting.Log_Line ("Close Error: " & Status'Img);
   end if;

   List_Dir (My_VFS, "/");
   List_Dir (My_VFS, "/test1");
   List_Dir (My_VFS, "/test1/");
end Main;

Add disk partition listing

examples/filesystem: Add disk partition listing


-----------------------------------------------------------------------
--  ado-mysql -- Database Drivers
--  Copyright (C) 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ADO.Configs;
with ADO.Connections.Mysql;

package body ADO.Mysql is

   --  ------------------------------
   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   --  ------------------------------
   procedure Initialize (Config : in String) is
   begin
      ADO.Configs.Initialize (Config);
      ADO.Connections.Mysql.Initialize;
   end Initialize;

   --  ------------------------------
   --  Initialize the drivers and the library and configure the runtime with the given properties.
   --  ------------------------------
   procedure Initialize (Config : in Util.Properties.Manager'Class) is
   begin
      ADO.Configs.Initialize (Config);
      ADO.Connections.Mysql.Initialize;
   end Initialize;

end ADO.Mysql;

-----------------------------------------------------------------------
--  ado-mysql -- Database Drivers
--  Copyright (C) 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with ADO.Configs;
with ADO.Connections.Mysql;

package body ADO.Mysql is

   --  ------------------------------
   --  Initialize the Mysql driver.
   --  ------------------------------
   procedure Initialize is
   begin
      ADO.Connections.Mysql.Initialize;
   end Initialize;

   --  ------------------------------
   --  Initialize the drivers and the library by reading the property file
   --  and configure the runtime with it.
   --  ------------------------------
   procedure Initialize (Config : in String) is
   begin
      ADO.Configs.Initialize (Config);
      Initialize;
   end Initialize;

   --  ------------------------------
   --  Initialize the drivers and the library and configure the runtime with the given properties.
   --  ------------------------------
   procedure Initialize (Config : in Util.Properties.Manager'Class) is
   begin
      ADO.Configs.Initialize (Config);
      Initialize;
   end Initialize;

end ADO.Mysql;

Implement the Initialize procedure and use it


-----------------------------------------------------------------------
--  security-openid -- Open ID 2.0 Support
--  Copyright (C) 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;

with Security.Permissions;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Permissions.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The process is the following:
   --
   --  o Initialize is called to configure the OpenID realm and set the
   --    OpenID return callback CB.
   --  o Discover is called to retrieve from the OpenID provider the XRDS
   --    stream and identify the provider.  An End_Point is returned.
   --  o Associate is called to make the association with the End_Point.
   --    The Association record holds session, and authentication.
   --  o Get_Authentication_URL builds the provider OpenID authentication
   --    URL for the association.
   --  o The user should be redirected to the authentication URL.
   --  o The OpenID provider authenticate the user and redirects the user to the callback CB.
   --  o The association is decoded from the callback parameter.
   --  o Verify is called with the association to check the result and
   --    obtain the authentication results.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Permissions.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

-----------------------------------------------------------------------
--  security-openid -- Open ID 2.0 Support
--  Copyright (C) 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;

with Security.Permissions;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  === Authentication process ==
--  The process is the following:
--
--    * The Initialize procedure is called to configure the OpenID realm and set the
--      OpenID return callback CB.
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--    * The Get_Authentication_URL builds the provider OpenID authentication
--      URL for the association.
--    * The application should redirected the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Permissions.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Permissions.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

Document the OpenID process

Document the OpenID process