------------------------------------------------------------------------------
-- Ada Web Server --
-- --
-- Copyright (C) 2007-2015, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 3, or (at your option) any --
-- later version. This library is distributed in the hope that it will be --
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are --
-- granted additional permissions described in the GCC Runtime Library --
-- Exception, version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
------------------------------------------------------------------------------
pragma Ada_2012;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Hash;
with AWS.Parameters;
with GNAT.Regpat;
package body AWS.Services.Web_Block.Registry is
use GNAT;
Context_Var : constant String := "CTX_WB";
type Lazy_Handler is new Templates.Dynamic.Lazy_Tag with record
Request : aliased Status.Data;
-- Current request made to the server
Translations : Templates.Translate_Set;
-- Global translations table
Ctx : aliased Context.Object;
-- Current context
end record;
overriding procedure Value
(Lazy_Tag : not null access Lazy_Handler;
Var_Name : String;
Translations : in out Templates.Translate_Set);
-- Handle lazy tags
type Web_Object_Data_Callback (With_Params : Boolean := False) is record
case With_Params is
when False =>
Callback : Data_Callback;
when True =>
Callback_With_Parameters : Data_With_Param_Callback;
end case;
end record;
type Web_Object (Callback_Template : Boolean := False) is record
Content_Type : Unbounded_String;
Context_Required : Boolean;
Data_CB : Web_Object_Data_Callback;
case Callback_Template is
when False =>
Template : Unbounded_String;
when True =>
Template_CB : Template_Callback;
end case;
end record;
package Web_Object_Maps is new Ada.Containers.Indefinite_Hashed_Maps
(String, Web_Object, Strings.Hash, "=");
use Web_Object_Maps;
-- Wrap access to the shared map with a protected object for safe
-- concurrent access.
protected WO_Store is
procedure Include (Key : String; WO : Web_Object);
-- Include an element in the map
procedure Find (Key : String; Position : out Web_Object_Maps.Cursor);
-- Returns a cursor pointing to element Key (or No_Element)
procedure Element
(Position : Web_Object_Maps.Cursor;
WO : out Web_Object);
-- Returns element pointed to by Position
private
WO_Map : Map;
end WO_Store;
type Pattern_Matcher_Access is access all GNAT.Regpat.Pattern_Matcher;
type URL_Pattern (With_Matcher : Boolean := False) is record
Prefix : Unbounded_String;
case With_Matcher is
when True =>
Matcher : Pattern_Matcher_Access;
Key : Unbounded_String;
when False =>
null;
end case;
end record;
package Pattern_URL_Container is new Ada.Containers.Vectors
(Positive, URL_Pattern);
Pattern_URL_Vector : Pattern_URL_Container.Vector;
-----------
-- Build --
-----------
function Build
(Key : String;
Request : Status.Data;
Translations : Templates.Translate_Set;
Status_Code : Messages.Status_Code := Messages.S200;
Cache_Control : Messages.Cache_Option := Messages.Unspecified;
Context : access Web_Block.Context.Object := null;
Context_Error : String := "") return Response.Data
is
function Get_Context return Web_Block.Context.Object;
-- Returns the context object
-----------------
-- Get_Context --
-----------------
function Get_Context return Web_Block.Context.Object is
begin
if Context = null then
return Web_Block.Context.Empty;
else
return Context.all;
end if;
end Get_Context;
P : constant Page :=
Parse (Key, Request, Translations, Get_Context, Context_Error);
Data : Response.Data;
begin
if P = No_Page then
Data := Response.Build
(MIME.Text_HTML, "", Status_Code => Messages.S404);
else
Data := Response.Build
(To_String (P.Content_Type),
To_String (P.Content),
Status_Code => Status_Code,
Cache_Control => Cache_Control);
end if;
-- Return the new context
if Context /= null then
Context.all := Web_Block.Context.Get (P.Ctx_Id);
end if;
return Data;
end Build;
------------------
-- Content_Type --
------------------
function Content_Type (Key : String) return String is
Position : Web_Object_Maps.Cursor;
begin
WO_Store.Find (Key, Position);
if Position = No_Element then
return "";
else
declare
WO : Web_Object;
begin
WO_Store.Element (Position, WO);
return To_String (WO.Content_Type);
end;
end if;
end Content_Type;
-----------------
-- Get_Context --
------------------
function Get_Context
(Request : Status.Data) return Web_Block.Context.Object
is
Ctx : constant String :=
Parameters.Get (Status.Parameters (Request), Context_Var);
begin
if Ctx = "" then
return Context.Empty;
else
return Context.Get (Context.Value (Ctx));
end if;
end Get_Context;
-----------
-- Parse --
-----------
function Parse
(Key : String;
Request : Status.Data;
Translations : Templates.Translate_Set;
Context : Web_Block.Context.Object := Web_Block.Context.Empty;
Context_Error : String := "") return Page
is
use type Web_Block.Context.Object;
function Get_Context return Web_Block.Context.Object;
-- Returns the context as passed to Parse routine if not empty, or the
-- one retrieved from the Web page.
-----------------
-- Get_Context --
-----------------
function Get_Context return Web_Block.Context.Object is
begin
if Context = Web_Block.Context.Empty then
return Get_Context (Request);
else
return Context;
end if;
end Get_Context;
Tag_Context_Var : constant String :=
Templates.Tag_From_Name (Context_Var);
Ctx : constant String :=
Parameters.Get
(Status.Parameters (Request), Context_Var);
LT : aliased Lazy_Handler :=
Lazy_Handler'(Templates.Dynamic.Lazy_Tag
with Request => Request,
Translations => Translations,
Ctx => Get_Context);
Position : Web_Object_Maps.Cursor;
function Get_Matching_Web_Object return Callback_Parameters;
-- Get the Web_Object matching Search_Key in Pattern_URL_Vector
-- Returns the Parameters extracted from the URL patterns.
-----------------------------
-- Get_Matching_Web_Object --
-----------------------------
function Get_Matching_Web_Object return Callback_Parameters is
begin
WO_Store.Find (Key, Position);
if Position /= No_Element then
return Empty_Callback_Parameters;
end if;
for Vector_Cursor in Pattern_URL_Vector.Iterate loop
declare
use GNAT.Regpat;
use Pattern_URL_Container;
P_URI : constant URL_Pattern := Element (Vector_Cursor);
K : constant String := To_String (P_URI.Prefix);
begin
if K'Length <= Key'Length
and then Key (Key'First .. Key'First + K'Length - 1) = K
then
-- If a regexp is defined, check whether it matched
if P_URI.With_Matcher then
declare
Count : constant Natural :=
Paren_Count (P_URI.Matcher.all);
Matched : Match_Array (0 .. Count);
begin
Match (Self => P_URI.Matcher.all,
Data => Key,
Matches => Matched);
if Matched (0) /= No_Match then
-- Returns the registered web object
-- Registered with a key = Prefix + Regexp
WO_Store.Find (To_String (P_URI.Key), Position);
declare
Params : Callback_Parameters (1 .. Count);
begin
for J in 1 .. Count loop
Params (J) :=
To_Unbounded_String
(Key (Matched (J).First
.. Matched (J).Last));
end loop;
return Params;
end;
end if;
end;
else
-- Only a prefix is defined.
-- No need to search for other candidates
WO_Store.Find (K, Position);
return Empty_Callback_Parameters;
end if;
end if;
end;
end loop;
return Empty_Callback_Parameters;
end Get_Matching_Web_Object;
Parsed_Page : Page := No_Page;
Parameters : constant Callback_Parameters := Get_Matching_Web_Object;
begin
-- Use provided context if a user's defined one
if Position /= No_Element then
declare
T : Templates.Translate_Set;
Template_Name : Unbounded_String;
Content : Unbounded_String;
C_Index : Natural;
CID : Web_Block.Context.Id;
Element : Web_Object;
begin
WO_Store.Element (Position, Element);
-- Get translation set for this tag
if Ctx = "" and then Element.Context_Required then
-- No context but it is required
return Parse (Context_Error, Request, Translations);
else
Templates.Insert (T, Translations);
-- Call the Data_CB
if not Element.Data_CB.With_Params then
if Element.Data_CB.Callback /= null then
Element.Data_CB.Callback (LT.Request, LT.Ctx'Access, T);
end if;
else
if Element.Data_CB.Callback_With_Parameters /= null then
Element.Data_CB.Callback_With_Parameters
(LT.Request, LT.Ctx'Access, Parameters, T);
end if;
end if;
if Element.Callback_Template then
Template_Name := To_Unbounded_String
(Element.Template_CB (Request));
else
Template_Name := Element.Template;
end if;
-- Page is now parsed, we need to create the context id for
-- this page.
LT.Translations := T;
Content := Templates.Parse
(To_String (Template_Name), T,
Lazy_Tag => LT'Unchecked_Access);
CID := Web_Block.Context.Register (LT.Ctx);
-- Finaly inject the context Id into the result
-- Note that any change in the format of the context below
-- will affect the Web Block Javascript runtime. So a
-- corresponding change must be done into aws_kernel.tjs.
-- Check if we have an explicite context in the template. In
-- this case we inject the context into this variable. If not
-- we inject the context into HTML and XML document as follow.
C_Index := Index (Content, Tag_Context_Var);
if Element.Content_Type = MIME.Text_HTML
and then C_Index = 0
then
-- A web page, we insert the context just after the
--
tag, format:
--
-- CID
--
C_Index := Index (Content, "");
if C_Index = 0 then
-- If not found, look for a body with some attributes
C_Index := Index (Content, "", From => C_Index);
if C_Index /= 0 then
Insert
(Content, C_Index + 1,
""
& Web_Block.Context.Image (CID) & "
");
end if;
end if;
elsif Element.Content_Type = MIME.Text_XML
and then C_Index = 0
then
-- Inject context into the XML response, format:
--
--
--
C_Index := Index (Content, "");
if C_Index /= 0 then
Insert
(Content, C_Index,
"");
end if;
elsif C_Index /= 0 then
-- Replace all context variables
Replace_Contexts : loop
Replace_Slice
(Content,
Low => C_Index,
High => C_Index + Tag_Context_Var'Length - 1,
By => Web_Block.Context.Image (CID));
C_Index := Index
(Content, Tag_Context_Var, From => C_Index + 1);
exit Replace_Contexts when C_Index = 0;
end loop Replace_Contexts;
end if;
Parsed_Page :=
Page'(Content_Type => Element.Content_Type,
Content => Content,
Set => Templates.Null_Set,
Ctx_Id => CID);
end if;
end;
end if;
return Parsed_Page;
end Parse;
--------------
-- Register --
--------------
procedure Register
(Key : String;
Template : String;
Data_CB : Data_Callback;
Content_Type : String := MIME.Text_HTML;
Prefix : Boolean := False;
Context_Required : Boolean := False)
is
WO : constant Web_Object :=
(Callback_Template => False,
Content_Type => To_Unbounded_String (Content_Type),
Template => To_Unbounded_String (Template),
Data_CB => Web_Object_Data_Callback'
(With_Params => False,
Callback => Data_CB),
Context_Required => Context_Required);
begin
-- Register Tag
WO_Store.Include (Key, WO);
if Prefix then
Pattern_URL_Container.Append
(Pattern_URL_Vector,
URL_Pattern'(Prefix => To_Unbounded_String (Key),
With_Matcher => False));
end if;
end Register;
--------------
-- Register --
--------------
procedure Register
(Key : String;
Template_CB : Template_Callback;
Data_CB : Data_Callback;
Content_Type : String := MIME.Text_HTML;
Context_Required : Boolean := False)
is
WO : constant Web_Object :=
(Callback_Template => True,
Content_Type => To_Unbounded_String (Content_Type),
Template_CB => Template_CB,
Data_CB => Web_Object_Data_Callback'
(With_Params => False,
Callback => Data_CB),
Context_Required => Context_Required);
begin
-- Register Tag
WO_Store.Include (Key, WO);
end Register;
--------------------------
-- Register_Pattern_URL --
--------------------------
procedure Register_Pattern_URL
(Prefix : String;
Regexp : String;
Template : String;
Data_CB : Data_With_Param_Callback;
Content_Type : String := MIME.Text_HTML;
Context_Required : Boolean := False)
is
WO : constant Web_Object :=
(Callback_Template => False,
Content_Type => To_Unbounded_String (Content_Type),
Template => To_Unbounded_String (Template),
Data_CB => Web_Object_Data_Callback'
(With_Params => True,
Callback_With_Parameters => Data_CB),
Context_Required => Context_Required);
Key : constant String := Prefix & Regexp;
Matcher : constant Pattern_Matcher_Access :=
new Regpat.Pattern_Matcher'
(Regpat.Compile (Key, Regpat.Case_Insensitive));
begin
-- Register Tag
WO_Store.Include (Key, WO);
Pattern_URL_Container.Append
(Pattern_URL_Vector,
URL_Pattern'(Prefix => To_Unbounded_String (Prefix),
With_Matcher => True,
Key => To_Unbounded_String (Key),
Matcher => Matcher));
end Register_Pattern_URL;
procedure Register_Pattern_URL
(Prefix : String;
Regexp : String;
Template_CB : Template_Callback;
Data_CB : Data_With_Param_Callback;
Content_Type : String := MIME.Text_HTML;
Context_Required : Boolean := False)
is
WO : constant Web_Object :=
(Callback_Template => True,
Content_Type => To_Unbounded_String (Content_Type),
Template_CB => Template_CB,
Data_CB => Web_Object_Data_Callback'
(With_Params => True,
Callback_With_Parameters => Data_CB),
Context_Required => Context_Required);
Key : constant String := Prefix & Regexp;
Matcher : constant Pattern_Matcher_Access :=
new Regpat.Pattern_Matcher'
(Regpat.Compile (Key, Regpat.Case_Insensitive));
begin
-- Register Tag
WO_Store.Include (Key, WO);
Pattern_URL_Container.Append
(Pattern_URL_Vector,
URL_Pattern'(Prefix => To_Unbounded_String (Prefix),
With_Matcher => True,
Key => To_Unbounded_String (Key),
Matcher => Matcher));
end Register_Pattern_URL;
-----------
-- Value --
-----------
overriding procedure Value
(Lazy_Tag : not null access Lazy_Handler;
Var_Name : String;
Translations : in out Templates.Translate_Set)
is
Position : Web_Object_Maps.Cursor;
begin
-- Specific case for the contextual var
if Var_Name = Context_Var then
-- We do not want to remove the context var now, just replace it by
-- the corresponding context var name. The proper context will be
-- injected into the Web page later.
Templates.Insert
(Translations,
Templates.Assoc
(Context_Var, Templates.Tag_From_Name (Context_Var)));
else
-- Get Web Object
WO_Store.Find (Var_Name, Position);
if Position /= No_Element then
declare
Keep : constant Templates.Translate_Set :=
Lazy_Tag.Translations;
T : Templates.Translate_Set;
Template_Name : Unbounded_String;
Element : Web_Object;
begin
-- Get translation set for this tag
Templates.Insert (T, Translations);
Templates.Insert (T, Lazy_Tag.Translations);
WO_Store.Element (Position, Element);
if not Element.Data_CB.With_Params
and then Element.Data_CB.Callback /= null
then
Element.Data_CB.Callback
(Lazy_Tag.Request, Lazy_Tag.Ctx'Access, T);
end if;
if Element.Callback_Template then
Template_Name := To_Unbounded_String
(Element.Template_CB (Lazy_Tag.Request));
else
Template_Name := Element.Template;
end if;
Lazy_Tag.Translations := T;
Templates.Insert
(Translations,
Templates.Assoc
(Var_Name,
Unbounded_String'(Templates.Parse
(To_String (Template_Name), T,
Lazy_Tag =>
Templates.Dynamic.Lazy_Tag_Access (Lazy_Tag)))));
-- We restore the lazy tag state as we do not want to
-- propagate changes to siblings.
Lazy_Tag.Translations := Keep;
end;
end if;
end if;
end Value;
--------------
-- WO_Store --
--------------
protected body WO_Store is
-------------
-- Element --
-------------
procedure Element
(Position : Web_Object_Maps.Cursor;
WO : out Web_Object) is
begin
WO := Web_Object_Maps.Element (Position);
end Element;
----------
-- Find --
----------
procedure Find (Key : String; Position : out Web_Object_Maps.Cursor) is
begin
Position := WO_Map.Find (Key);
end Find;
-------------
-- Include --
-------------
procedure Include (Key : String; WO : Web_Object) is
begin
WO_Map.Include (Key, WO);
end Include;
end WO_Store;
end AWS.Services.Web_Block.Registry;