1/*  Part of SWISH
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2014-2016, VU University Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(swish_form,
   36	  [ validate_form/2,		% +Dict, +Fields
   37	    validate_field/4,		% +Dict, +Field, -Value, +Options
   38	    input_error/2		% +Field, +Error
   39	  ]).

 validate_form(+Dict, +Fields) is det

Run validate_field/4 on all specified fields, combining the error message. Fields is a list of terms of the form

field(Name, Value, Options)

   57validate_form(Dict, Fields) :-
   58	validate_form(Fields, Dict, Errors),
   59	(   Errors == []
   60	->  true
   61	;   throw(error(form_error(Errors), _))
   62	).
   63
   64validate_form([], _, []).
   65validate_form([field(Field, Value, Options)|T], Dict, Errors) :-
   66	catch(validate_field(Dict, Field, Value, Options),
   67	      error(input_error(Field, Error),_),
   68	      true),
   69	(   var(Error)
   70	->  Errors = Errors1
   71	;   Errors = [input_error(Field, Error)|Errors1]
   72	),
   73	validate_form(T, Dict, Errors1).

 validate_field(+Dict, +Field, -Value, +Options) is det

True when Value is a valid value for Field from Dict according to Options. Options is a list of processing steps taken to convert and validate the value. Defined steps are:

alnum

All characters must be alphanumeric

alnum_and_spaces

All characters must be alphanumeric or spaces

atom

Convert input to an atom

string

Convert input to a string

default(Term)

Use Term as value if no value appears in the input.

downcase

Convert input to lower case

email

Input must be a value E-mail address.

url

Input must be a valid absolute URL

url(Scheme)

Input must be a valid absolute URL of type Scheme. Using http also allows for https

float

Value is converted to a floating point number.

integer

Value is converted to an integer.

length>N

The value must have at more than N characters

length>=N

The value must have at least N characters

length=<N

The value must have at most N characters

length<N

The value must have at less than N characters

number

Value is converted to a number (integer or float)

oneof(List)

Input must be a member of List.

password

Input must be a reasonable password.

strip

Strip leading and trailing white space and normalize internal white space to a single space.

term

Input is parsed as a Prolog term

  126validate_field(Dict, Field, Value, Options) :-
  127	(   Value0 = Dict.get(Field),
  128	    \+ is_empty(Value0)
  129	->  validate_value(Options, Value0, Value, Field)
  130	;   memberchk(default(Value), Options)
  131	->  true
  132	;   input_error(Field, required)
  133	).
  134
  135is_empty(Value) :-
  136	text(Value),
  137	normalize_space(string(""), Value).
  138
  139text(Value) :- atom(Value), !.
  140text(Value) :- string(Value).
  141
  142validate_value([], Value, Value, _).
  143validate_value([H|T], Value0, Value, Field) :-
  144	(   validate_step(H, Value0, Value1)
  145	->  true
  146	;   current_type(H, _, _),
  147	    is_of_type(H, Value0)
  148	->  Value1 = Value0
  149	;   validate_failed(H, Value0, Field)
  150	),
  151	validate_value(T, Value1, Value, Field).

 validate_step(+Step, +Value0, -Value) is semidet

  155validate_step(alnum, Value, Value) :-
  156	forall(sub_atom(Value, _, 1, _, Char),
  157	       char_type(Char, alnum)).
  158validate_step(length >= N, Value, Value) :-
  159	string_length(Value, Len),
  160	Len >= N.
  161validate_step(length > N, Value, Value) :-
  162	string_length(Value, Len),
  163	Len > N.
  164validate_step(length < N, Value, Value) :-
  165	string_length(Value, Len),
  166	Len < N.
  167validate_step(length =< N, Value, Value) :-
  168	string_length(Value, Len),
  169	Len =< N.
  170validate_step(strip, Value0, Value) :-
  171	normalize_space(string(Value), Value0).
  172validate_step(term, Value0, Value) :-
  173	term_string(Value, Value0).
  174validate_step(alnum_and_spaces, Value, Value) :-
  175	forall(sub_atom(Value, _, 1, _, Char),
  176	       alnum_or_space(Char)).
  177validate_step(email, Value, Value) :-
  178	string_codes(Value, Codes),
  179	phrase(email, Codes).
  180validate_step(url, Value, Value) :-
  181	validate_step(url(_), Value, Value).
  182validate_step(url(Scheme), Value, Value) :-
  183	is_url(Scheme, Value).
  184validate_step(downcase, Value0, Value) :-
  185	string_lower(Value0, Value).
  186validate_step(atom, Value0, Value) :-
  187	atom_string(Value, Value0).
  188validate_step(string, Value0, Value) :-
  189	(   string(Value0)
  190	->  Value = Value0
  191	;   atom_string(Value0, Value)
  192	).
  193validate_step(number, Value0, Value) :-
  194	number_string(Value, Value0).
  195validate_step(integer, Value0, Value) :-
  196	number_string(Value, Value0),
  197	integer(Value).
  198validate_step(float, Value0, Value) :-
  199	number_string(Value1, Value0),
  200	Value is float(Value1).
  201validate_step(oneof(List), Value0, Value) :-
  202	member(Value, List),
  203	string_value(Value0, Value), !.
  204validate_step(password, Value, Value) :-
  205	string_length(Value, Len),
  206	Len >= 6.
  207validate_step(default(_), Value, Value).
  208
  209alnum_or_space(' ') :- !.
  210alnum_or_space(Char) :-
  211	char_type(Char, alnum).
  212
  213email --> user_name, "@", domain_name.
  214user_name --> user_name_char, user_name_chars.
  215domain_name --> domain_name_segment, ".", domain_name_segments.
  216
  217user_name_chars --> user_name_char, !, user_name_chars.
  218user_name_chars --> "".
  219
  220user_name_char -->
  221	[C],
  222	{ between(1, 127, C),
  223	  (   code_type(C, alnum)
  224	  ->  true
  225	  ;   name_special(C)
  226	  )
  227	}.
  228
  229name_special(0'.).
  230name_special(0'-).
  231
  232domain_name_segment --> domain_name_char, domain_name_chars.
  233domain_name_segments -->
  234	domain_name_segment,
  235	(   "."
  236	->  domain_name_segments
  237	;   ""
  238	).
  239
  240domain_name_chars --> domain_name_char, !, domain_name_chars.
  241domain_name_chars --> "".
  242
  243domain_name_char -->
  244	[C],
  245	{ between(1, 127, C),
  246	  (   code_type(C, alnum)
  247	  ->  true
  248	  ;   domain_special(C)
  249	  )
  250	}.
  251
  252domain_special(0'-).
  253domain_special(0'_).

 is_url(?Scheme, +URL) is semidet

True if URL looks like a URL that satisfies Scheme.

  259is_url(Scheme, URL) :-
  260	(   string(URL)
  261	->  true
  262	;   atom(URL)
  263	),
  264	uri_components(URL, Components),
  265	valid_url_scheme(Scheme, Components),
  266	valid_authority(Components).
  267
  268valid_url_scheme(SchemeReq, Components) :-
  269	uri_data(scheme, Components, Scheme),
  270	nonvar(Scheme),
  271	is_scheme(SchemeReq, Scheme).
  272
  273is_scheme(Scheme, Scheme) :- !.
  274is_scheme(http, https).
  275
  276valid_authority(Components) :-
  277	uri_data(authority, Components, Authority),
  278	nonvar(Authority).

 string_value(+String, +Value) is semidet

True if String can be considered the stringified version of Value.

  285string_value(Value, Value) :- !.
  286string_value(String, Value) :-
  287	atom(Value),
  288	atom_string(Value, String), !.
  289string_value(String, Value) :-
  290	number(Value),
  291	number_string(String, Value1),
  292	Value1 =:= Value.
  293
  294validate_failed(H, _Value0, Field) :-
  295	input_error(Field, H).
  296
  297input_error(Field, Error) :-
  298	throw(error(input_error(Field, Error), _)).
  299
  300
  301		 /*******************************
  302		 *	     MESSAGES		*
  303		 *******************************/
  304
  305:- multifile prolog:error_message//1.  306
  307prolog:error_message(input_error(Field, Expected)) -->
  308	[ '~w: '-[Field] ],
  309	expected(Expected).
  310prolog:error_message(form_error(Errors)) -->
  311	field_errors(Errors).
  312
  313field_errors([]) --> [].
  314field_errors([H|T]) -->
  315	prolog:error_message(H),
  316	(   {T==[]}
  317	->  []
  318	;   [nl],
  319	    field_errors(T)
  320	).
  321
  322
  323expected(oneof(List)) --> !,
  324	[ 'One of '-[] ],
  325	oneof(List).
  326expected(required) --> !,
  327	[ 'This field is required'-[] ].
  328expected(length > N) --> !,
  329	[ 'Needs at more than ~d characters'-[N] ].
  330expected(length >= N) --> !,
  331	[ 'Needs at least ~d characters'-[N] ].
  332expected(length =< N) --> !,
  333	[ 'Needs at most ~d characters'-[N] ].
  334expected(length < N) --> !,
  335	[ 'Needs less than ~d characters'-[N] ].
  336expected(matching_password) -->
  337	[ 'The password does not match'-[] ].
  338expected(new_user) -->
  339	[ 'A user with this name already exists'-[] ].
  340expected(Expected) --> !,
  341	[ 'This field must hold a valid ~w'-[Expected] ].
  342
  343oneof([One]) --> !,
  344	[ '~w'-[One] ].
  345oneof([One, Two]) --> !,
  346	[ '~w or ~w'-[One, Two] ].
  347oneof([H|T]) -->
  348	[ '~w, '-[H] ],
  349	oneof(T)