1:- module(uri_qq, [uri/4]).    2:- use_module(library(apply), [maplist/3]).    3:- use_module(library(quasi_quotations)).    4:- use_module(library(readutil), [read_stream_to_codes/2]).    5:- use_module(library(record)).    6:- use_module(library(uri), [uri_components/2, uri_data/3]).    7
    8
    9% We parse the quasiquotation content into a URI term, replace $-escaped
   10% variables with their values, then convert the URI term back into an
   11% atom. The round trip makes sure that all necessary escaping
   12% and normalization is done properly.
   13%
   14% I wanted to use library(uri) directly, but it leaves too many of the
   15% URI's components hidden inside opaque atoms (authority, path segments,
   16% query name-value pairs). The uriqq record splits everything down to
   17% the smallest structural level.
   18
   19% represents a URI with more structure than library(uri) provides
   20:- record uriqq( scheme
   21               , user
   22               , password
   23               , host
   24               , port
   25               , path
   26               , search
   27               , fragment
   28               ).
   29
   30% atom_uri(+Atom, -Uri)
   31% atom_uri(-Atom, +Uri)
   32%
   33% True if Atom represents the structured Uri.
   34atom_uri(Atom, UriQQ) :-
   35    var(Atom),
   36    uri_uriqq(Uri, UriQQ),
   37    uri_components(Atom, Uri).
   38atom_uri(Atom, UriQQ) :-
   39    atom(Atom),
   40    uri_components(Atom, Uri),
   41    uri_uriqq(Uri, UriQQ).
   42
   43
   44% describe relation between uri_components and uriqq terms
   45uri_uriqq(Uri, UriQQ) :-
   46    scheme(Uri, UriQQ),
   47    authority(Uri, UriQQ),
   48    path(Uri, UriQQ),
   49    search(Uri, UriQQ),
   50    fragment(Uri, UriQQ).
   51
   52scheme(Uri, UriQQ) :-
   53    uri_data(scheme, Uri, Scheme),
   54    uriqq_data(scheme, UriQQ, Scheme).
   55
   56authority(Uri, UriQQ) :-
   57    uri_data(authority, Uri, Authority),
   58    uri_authority_data(user,     As, User),
   59    uri_authority_data(password, As, Password),
   60    uri_authority_data(host,     As, Host),
   61    uri_authority_data(port,     As, Port),
   62
   63    uriqq_data(user,     UriQQ, User),
   64    uriqq_data(password, UriQQ, Password),
   65    uriqq_data(host,     UriQQ, Host),
   66    uriqq_data(port,     UriQQ, Port),
   67
   68    ( var(Authority), var(User), var(Password), var(Host), var(Port)
   69    ; uri_authority_components(Authority, As)
   70    ).
   71
   72path(Uri, UriQQ) :-
   73    uri_data(path, Uri, PathA),
   74    uriqq_data(path, UriQQ, PathB),
   75    ( var(PathA), var(PathB)
   76    ; nonvar(PathB),
   77      maplist(path_term,PathC,PathB),
   78      atomic_list_concat(PathC,/,PathA)
   79    ; atomic_list_concat(PathB,/,PathA)
   80    ).
   81
   82search(Uri, UriQQ) :-
   83    uri_data(search, Uri, Search),
   84    uriqq_data(search, UriQQ, Pairs),
   85    ( var(Search), var(Pairs)
   86    ; atom(Search), atom_concat('$', _, Search), Pairs=Search
   87    ; is_dict(Pairs),
   88      dict_pairs(Pairs, _, Pairs1),
   89      uri_query_components(Search, Pairs1)
   90    ; uri_query_components(Search, Pairs)
   91    ).
   92
   93fragment(Uri, UriQQ) :-
   94    uri_data(fragment, Uri, Fragment),
   95    uriqq_data(fragment, UriQQ, Fragment).
   96
   97replace_variables(Vars, Term0, Term) :-
   98    % $-prefixed variable needing substitution
   99    atom(Term0),
  100    atom_concat('$', Name, Term0),
  101    !,
  102    ( memberchk(Name=Value, Vars) ->
  103        Term = Value
  104    ; % otherwise ->
  105        Term = Term0
  106    ).
  107replace_variables(Vars, Term0, Term) :-
  108    % compound term needing recursive replacement
  109    nonvar(Term0),
  110    Term0 =.. [Name|Args0],
  111    !,
  112    maplist(replace_variables(Vars), Args0, Args),
  113    Term =.. [Name|Args].
  114replace_variables(_, Term, Term) :-
  115    % leave everything else alone
  116    true.
  117
  118path_term(Path, Term) :-
  119    var(Path),
  120    Term = _/_,
  121    !,
  122    list_slashes(PathList, Term),
  123    atomic_list_concat(PathList, /, Path).
  124path_term(Path, Term) :-
  125    atom(Term),
  126    Path = Term.
  127
  128% relate a list to a slash-separated term
  129list_slashes(List, Slashes) :-
  130    nonvar(List),
  131    !,
  132    reverse(List, ReverseList),
  133    list_slashes_(ReverseList, Slashes).
  134list_slashes(List, Slashes) :-
  135    nonvar(Slashes),
  136    list_slashes_(ReverseList, Slashes),
  137    reverse(ReverseList, List).
  138
  139list_slashes_([Tail|Path], Head/Tail) :-
  140    Path \== [],
  141    !,
  142    list_slashes_(Path, Head).
  143list_slashes_([X], X).
  144
  145% parse quasiquotation into a result
  146qq(Stream, Vars, MaybeBase, Result) :-
  147    read_stream_to_codes(Stream, Codes),
  148    atom_codes(Atom, Codes),
  149    qq_an_atom(Atom, Vars, UriQQ),
  150    uriqq_data(scheme, UriQQ, Scheme),
  151    ( var(Scheme) ->
  152        ( MaybeBase = just(Base) ->
  153            Result = uri_relative(Base, UriQQ)
  154        ; % otherwise ->
  155            Result = uri_suffix(UriQQ)
  156        )
  157    ; % otherwise ->
  158        Result = uri_absolute(UriQQ)
  159    ).
  160
  161qq_an_atom(Atom, Vars, Result) :-
  162    atom_uri(Atom, Uri0),
  163    replace_variables(Vars, Uri0, Result).
  164
  165:- quasi_quotation_syntax(uri).  166uri(Content,Args,Vars,Result) :-
  167    ( Args = [Base] ->
  168        MaybeBase = just(Base)
  169    ; % otherwise ->
  170        MaybeBase = none
  171    ),
  172    with_quasi_quotation_input(Content, Stream, qq(Stream,Vars,MaybeBase,Result)).
  173
  174
  175:- use_module(library(function_expansion)).  176user:function_expansion( uri_absolute(UriQQ)
  177                       , Atom
  178                       , once(uri_qq:atom_uri(Atom,UriQQ))
  179                       ).
  180user:function_expansion( uri_relative(Base, UriQQ)
  181                       , Atom
  182                       , ( once(uri_qq:atom_uri(RelUri,UriQQ))
  183                         , uri_resolve(RelUri, Base, Atom)
  184                         )
  185                       ).
  186user:function_expansion( uri_suffix(UriQQ)
  187                       , Atom
  188                       , ( once(uri_qq:atom_uri(Suffix,UriQQ))
  189                         , atom_concat('http://', Suffix, Atom)
  190                         )
  191                       )