View source with raw comments or as raw
    1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@cs.vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (C): 2013-2024, VU University Amsterdam
    7			      SWI-Prolog Solutions b.v.
    8
    9    This program is free software; you can redistribute it and/or
   10    modify it under the terms of the GNU General Public License
   11    as published by the Free Software Foundation; either version 2
   12    of the License, or (at your option) any later version.
   13
   14    This program is distributed in the hope that it will be useful,
   15    but WITHOUT ANY WARRANTY; without even the implied warranty of
   16    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   17    GNU General Public License for more details.
   18
   19    You should have received a copy of the GNU General Public
   20    License along with this library; if not, write to the Free Software
   21    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   22
   23    As a special exception, if you link this library with other files,
   24    compiled with a Free Software compiler, to produce an executable, this
   25    library does not by itself cause the resulting executable to be covered
   26    by the GNU General Public License. This exception does not however
   27    invalidate any other reasons why the executable file might be covered by
   28    the GNU General Public License.
   29*/
   30
   31
   32:- module(tagit,
   33	  [ user_tags//2,		% +User, +Options
   34	    user_tag_count/2,		% +User, -Count
   35	    tagit_footer//2		% +Object, +Options
   36	  ]).   37:- use_module(generics).   38:- use_module(library(debug)).   39:- use_module(library(persistency)).   40:- use_module(library(aggregate)).   41:- use_module(library(error)).   42:- use_module(library(dcg/basics)).   43:- use_module(library(http/html_head)).   44:- use_module(library(http/html_write)).   45:- use_module(library(http/js_write)).   46:- use_module(library(http/http_dispatch)).   47:- use_module(library(http/http_wrapper)).   48:- use_module(library(http/http_parameters)).   49:- use_module(library(http/http_json)).   50:- use_module(library(pldoc/doc_search)).   51:- use_module(library(pldoc/doc_html)).   52:- use_module(notify).   53:- use_module(object_support).   54:- use_module(openid).   55
   56:- html_resource(tagit,
   57		 [ ordered(true),
   58		   requires([ jquery_ui,
   59			      js('tagit/js/tag-it.min.js'),
   60			      js('tagit/css/jquery.tagit.css'),
   61			      js('tagit/css/tagit.ui-zendesk.css')
   62			    ]),
   63		   virtual(true)
   64		 ]).   65:- html_resource(css('tags.css'), []).   66
   67
   68		 /*******************************
   69		 *	       DATA		*
   70		 *******************************/
   71
   72:- persistent
   73	tagged(tag:atom,			% Name of the tag
   74	       object:any,			% Object attached to
   75	       time:integer,			% When was it tagged
   76	       user:atom),			% User that added the tag
   77	tag(tag:atom,
   78	    time:integer,			% When was it created
   79	    user:atom).   80
   81user_tag_count(User, Count) :-
   82	aggregate_all(count, tagged(_,_,_,User), Count).
   83
   84
   85:- initialization
   86	absolute_file_name(data('tags.db'), File,
   87			   [ access(write) ]),
   88	db_attach(File,
   89		  [ sync(close)
   90		  ]).   91
   92current_tag(Tag) :-
   93	tag(Tag, _, _).
   94
   95create_tag(Tag, _User) :-
   96	tag(Tag, _, _), !.
   97create_tag(Tag, User) :-
   98	get_time(NowF),
   99	Now is round(NowF),
  100	assert_tag(Tag, Now, User), !.
 tagit_user(+Request, -Type, -User) is det
User as seen for tagging. This is either the current user or the peer.
  108tagit_user(_Request, uuid, User) :-
  109	site_user_logged_in(User), !.
  110tagit_user(Request, ip, Peer) :-
  111	http_peer(Request, Peer).
  112
  113peer(Peer) :-
  114	atom_codes(Peer, Codes),
  115	phrase(ip, Codes).
  116
  117ip -->
  118	integer(_), ".",
  119	integer(_), ".",
  120	integer(_), ".",
  121	integer(_).
  122
  123
  124		 /*******************************
  125		 *	 PROLOG BINDING		*
  126		 *******************************/
  127
  128:- http_handler(root('complete-tag'), complete_tag, []).  129:- http_handler(root('show-tag'),     show_tag,	    []).  130:- http_handler(root('add-tag'),      add_tag,	    []).  131:- http_handler(root('remove-tag'),   remove_tag,   []).  132:- http_handler(root('list-tags'),    list_tags,    []).  133:- http_handler(root('tag-abuse'),    tag_abuse,    []).
 tagit_footer(+Obj, +Options)// is det
Show tagit widget for adding and deleting tags.
  139tagit_footer(Obj, _Options) -->
  140	{ http_link_to_id(complete_tag, [], Complete),
  141	  http_link_to_id(show_tag, [], OnClick),
  142	  http_link_to_id(add_tag, [], AddTag),
  143	  http_link_to_id(remove_tag, [], RemoveTag),
  144	  object_label(Obj, Label),
  145	  object_id(Obj, ObjectID),
  146	  format(atom(PlaceHolder), 'Tag ~w', [Label]),
  147	  object_tags(Obj, Tags)
  148	},
  149	html(div(id='tags-component',
  150		 [ \tag_notes(ObjectID, Tags),
  151		   div(id='tags-label', 'Tags:'),
  152		   div(id='tags-bar', ul(id=tags, \tags_li(Tags))),
  153		   div(id='tags-warnings', [])
  154		 ])),
  155	html_requires(css('tags.css')),
  156	html_requires(tagit),
  157	js_script({|javascript(Complete, OnClick, PlaceHolder, ObjectID,
  158			       AddTag, RemoveTag)||
  159		    function tagInfo(text) {
  160		      $("#tags-warnings").text(text);
  161		      $("#tags-warnings").removeClass("warning");
  162		      $("#tags-warnings").addClass("informational");
  163		    }
  164		    function tagWarning(text) {
  165		      $("#tags-warnings").text(text);
  166		      $("#tags-warnings").addClass("warning");
  167		      $("#tags-warnings").removeClass("informational");
  168		    }
  169
  170		    $(document).ready(function() {
  171		      $("#tags").tagit({
  172			  autocomplete: { delay: 0.3,
  173					  minLength: 1,
  174					  source: Complete
  175					},
  176			  onTagClicked: function(event, ui) {
  177			    window.location.href = OnClick+"?tag="+
  178			      encodeURIComponent(ui.tagLabel);
  179			  },
  180			  beforeTagAdded: function(event, ui) {
  181			    if ( !ui.duringInitialization ) {
  182			      var result = false;
  183			      tagInfo("Submitting ...");
  184			      $.ajax({ dataType: "json",
  185				       url: AddTag,
  186				       data: { tag: ui.tagLabel,
  187					       obj: ObjectID
  188					     },
  189				       async: false,
  190				       success: function(data) {
  191					if ( data.status == true ) {
  192					  tagInfo("Added: "+ui.tagLabel);
  193					  result = true;
  194					} else {
  195					  tagWarning(data.message);
  196					}
  197				      }
  198				     });
  199			      return result;
  200			    }
  201			  },
  202			  beforeTagRemoved: function(event, ui) {
  203			    var result = false;
  204			    if ( !ui.tagLabel ) {
  205			      return false;
  206			    }
  207			    tagInfo("Submitting ...");
  208			    $.ajax({ dataType: "json",
  209				     url: RemoveTag,
  210				     data: { tag: ui.tagLabel,
  211					     obj: ObjectID
  212					   },
  213				     async: false,
  214				     success: function(data) {
  215					if ( data.status == true ) {
  216					  tagInfo("Removed: "+ui.tagLabel);
  217					  result = true;
  218					} else {
  219					  tagWarning(data.message);
  220					}
  221				      }
  222				   });
  223			    return result;
  224			  },
  225			  placeholderText: PlaceHolder
  226			});
  227		      });
  228		  |}).
  229
  230tags_li([]) --> [].
  231tags_li([H|T]) --> html(li(H)), tags_li(T).
  232
  233tag_notes(ObjectID, Tags) -->
  234	html(div(id='tags-notes',
  235		 [ \why_login,
  236		   \abuse_link(ObjectID, Tags)
  237		 ])).
  238
  239abuse_link(_, []) --> [].
  240abuse_link(ObjectID, _) -->
  241	sep,
  242	{ http_link_to_id(tag_abuse, [obj=ObjectID], HREF)
  243	},
  244	html(a(href(HREF), 'Report abuse')).
  245
  246why_login -->
  247	{ site_user_logged_in(_) }, !.
  248why_login -->
  249	html('Tags are associated to your profile if you are logged in').
  250
  251sep -->
  252	html(span(class(separator), '|')).
  253
  254object_tags(Object, Tags) :-
  255	findall(Tag, tagged(Tag, Object, _Time, _User), Tags0),
  256	sort(Tags0, Tags).
 complete_tag(+Request)
Complete. Currently only uses existing tags for completion.
To be done
- Provide pre-populated completion (e.g., from FOLDOC)
- Show (as feedback) how often this is used, etc.
  265complete_tag(Request) :-
  266	http_parameters(Request,
  267			[ term(Q, [])
  268			]),
  269	debug(tag(autocomplete), 'Autocomplete ~q', [Q]),
  270	(   setof(A, tag_holding(Q,A), List)
  271	->  true
  272	;   List = []
  273	),
  274	reply_json(List).
  275
  276tag_holding(Term, Tag) :-
  277	current_tag(Tag),
  278	(   sub_atom(Tag, _, _, _, Term)
  279	->  true
  280	).
 add_tag(+Request)
Add tag to the given object
  286add_tag(Request) :-
  287	http_parameters(Request,
  288			[ tag(Tag, []),
  289			  obj(Hash, [])
  290			]),
  291	object_id(Object, Hash),
  292	tagit_user(Request, UserType, User),
  293	debug(tagit, 'add_tag: ~q: ~q to ~q', [User, Tag, Object]),
  294	add_tag_validate(Tag, Object, UserType, Message),
  295	(   var(Message)
  296	->  create_tag(Tag, User),
  297	    get_time(NowF),
  298	    Now is round(NowF),
  299	    assert_tagged(Tag, Object, Now, User),
  300	    notify(Object, tagged(Tag)),
  301	    reply_json_dict(json{status:true})
  302	;   reply_json_dict(json{status:false,
  303			         message:Message})
  304	).
  305
  306add_tag_validate(Tag, _Object, UserType, Message) :-
  307	tag_create_not_ok(Tag, UserType, Message), !.
  308add_tag_validate(Tag, Object, _UserType, Message) :-
  309	object_label(Object, Label),
  310	sub_atom_icasechk(Label, _, Tag), !,
  311	Message = 'Rejected: tag is part of object name'.
  312add_tag_validate(Tag, _Object, _UserType, Message) :-
  313	\+ current_op(_,_,system:Tag),
  314	tag_not_ok(Tag, Message), !.
  315add_tag_validate(_, _, _, _).
  316
  317tag_not_ok(Tag, Message) :-
  318	sub_atom(Tag, _, 1, _, Char),
  319	\+ tag_char_ok(Char), !,
  320	format(atom(Message), 'Illegal character: ~w', [Char]).
  321
  322tag_char_ok(Char) :- char_type(Char, alnum).
  323tag_char_ok('_').
  324tag_char_ok('-').
  325tag_char_ok('/').
  326tag_char_ok('(').
  327tag_char_ok(')').
  328
  329%tag_create_not_ok(_, ip, 'Not logged-in users can only use existing tags').
  330tag_create_not_ok(_, ip, 'Not logged-in users can not add tags').
 remove_tag(+Request)
Remove tag from the given object
  337remove_tag(Request) :-
  338	http_parameters(Request,
  339			[ tag(Tag, []),
  340			  obj(Hash, [])
  341			]),
  342	object_id(Object, Hash),
  343	tagit_user(Request, _, User),
  344	debug(tagit, 'remove_tag: ~q: ~q to ~q', [User, Tag, Object]),
  345	tagged(Tag, Object, _, Creator),
  346	(   may_remove(User, Creator)
  347	->  (   retract_tagged(Tag, Object, _, Creator),
  348	        gc_tag(Tag)
  349	    ->  notify(Object, untagged(Tag)),
  350		reply_json(json{status:true})
  351	    ;   reply_json(json{status:false,
  352				message:"Unknown error"
  353			       })
  354	    )
  355	;   reply_json(json{status:false,
  356			    message:"Permission denied"
  357			   })
  358	).
 may_remove(+CurrentUser, +Creator)
  362may_remove(User, User) :- !.
  363may_remove(User, _Anonymous) :-
  364	site_user_property(User, granted(admin)).
 gc_tag(+Tag)
Remove tag if it is no longer in use.
  370gc_tag(Tag) :-
  371	tagged(Tag, _, _, _), !.
  372gc_tag(Tag) :-
  373	retract_tag(Tag, _, _).
  374
  375gc_tags :-
  376	forall(tag(Tag,_,_),
  377	       gc_tag(Tag)).
 show_tag(+Request)
Show pages that are tagged with this tag.
  383show_tag(Request) :-
  384	http_parameters(Request,
  385			[ tag(Tag, [])
  386			]),
  387	findall(Obj, tagged(Tag, Obj, _, _), Objects0),
  388	sort(Objects0, Objects),
  389	reply_html_page(wiki(tags),
  390			title('Pages tagged "~w"'-[Tag]),
  391			[ h1(class(wiki), 'Pages tagged "~w"'-[Tag]),
  392			  \doc_resources([]),
  393			  \matching_object_table(Objects, [])
  394			]).
 tag_abuse(+Request)
Some user claims that the tag is abused.
  400tag_abuse(Request) :-
  401	site_user_logged_in(_), !,
  402	http_parameters(Request,
  403			[ obj(Hash, [])
  404			]),
  405	object_id(Object, Hash),
  406	Link = \object_ref(Object,[]),
  407	tagit_user(Request, uuid, _User),
  408	notify(Object, tag_abuse),
  409	reply_html_page(
  410	    wiki(tags),
  411	    title('Notification of abuse'),
  412	    {|html(Link)||
  413	     <h1 class="wiki">Notification of abuse sent</h1>
  414	     <p>
  415	     Thanks for reporting abuse of tagging on documentation object
  416	     <span>Link</span>.
  417	     |}).
  418tag_abuse(Request) :-
  419	memberchk(path(Path), Request),
  420	permission_error(access, http_location, Path).
  421
  422
  423
  424		 /*******************************
  425		 *   AUTOCOMPLETE INTEGRATION	*
  426		 *******************************/
  427
  428:- multifile
  429	prolog:ac_object/3,
  430	prolog:doc_object_href/2,		% +Object, -HREF
  431	prolog:doc_object_label_class/3,
  432	prolog:ac_object_attributes/2.
 prolog:ac_object(+MatchHow, +Term, -Match) is nondet
Provide additional autocompletion matches on tags,
  439prolog:ac_object(name, Term, Tag-tag(Tag)) :-
  440	current_tag(Tag),
  441	(   sub_atom_icasechk(Tag, 0, Term),
  442	    tagged(Tag, _, _, _)
  443	->  true
  444	).
  445prolog:ac_object(token, Term, Tag-tag(Tag)) :-
  446	current_tag(Tag),
  447	(   sub_atom_icasechk(Tag, _, Term),
  448	    tagged(Tag, _, _, _)
  449	->  true
  450	).
  451
  452prolog:doc_object_href(tag(Tag), HREF) :-
  453	http_link_to_id(show_tag, [tag(Tag)], HREF).
  454
  455prolog:doc_object_label_class(tag(Tag), Tag, tag).
  456
  457prolog:ac_object_attributes(tag(Tag), [tag=Info]) :-
  458	aggregate_all(count, tagged(Tag,_,_,_), Used),
  459	format(atom(Info), 'tag x~D', [Used]).
  460
  461
  462		 /*******************************
  463		 *	     LIST TAGS		*
  464		 *******************************/
 list_tags(+Request)
HTTP handler that lists the defined tags.
  470list_tags(Request) :-
  471	http_parameters(Request,
  472			[ sort_by(SortBy, [ oneof([ name,
  473						    popularity,
  474						    time
  475						  ]),
  476					    default(name)
  477					  ])
  478			]),
  479	reply_html_page(
  480	    tags(list),
  481	    title('Overview of tags'),
  482	    \user_tags(_, [sort_by(SortBy)])).
 user_tags(?User, +Options)// is det
Show all tags created by a given user.
  489user_tags(User, Options) -->
  490	{ findall(Tag-tag(Obj,Time), tagged(Tag, Obj, Time, User), Pairs),
  491	  Pairs \== [], !,
  492	  keysort(Pairs, Sorted),
  493	  group_pairs_by_key(Sorted, Keyed),
  494	  option(sort_by(SortBy), Options, name),
  495	  sort_tags(Keyed, SortedTags, SortBy)
  496	},
  497	html([ \tag_list_header(User, SortBy),
  498	       table(class('user-tags'),
  499		     \list_tags(SortedTags))
  500	     ]).
  501user_tags(_, _) --> [].
  502
  503tag_list_header(User, _SortBy) -->
  504	{ nonvar(User),
  505	  site_user_property(User, name(Name))
  506	}, !,
  507	html(h2(class(wiki), 'Tags by ~w'-[Name])).
  508tag_list_header(_User, SortBy) -->
  509	html(h2(class(wiki), 'Tags sorted by ~w'-[SortBy])).
  510
  511sort_tags(Tags, Tags, name) :- !.
  512sort_tags(Tags, Sorted, SortBy) :-
  513	map_list_to_pairs(sort_key_tag(SortBy),	Tags, Keyed),
  514	keysort(Keyed, KeySorted),
  515	pairs_values(KeySorted, Sorted).
  516
  517sort_key_tag(name,       Tag-_, Tag).
  518sort_key_tag(popularity, _-Tagged, Count) :-
  519	length(Tagged, Count).
  520sort_key_tag(time,	 _-Tagged, Last) :-
  521	maplist(arg(2), Tagged, Times),
  522	max_list(Times, Last).
 list_tags(+Tags)
List tags and what they are linked to.
  528list_tags([]) --> [].
  529list_tags([H|T]) --> list_tag(H), list_tags(T).
  530
  531list_tag(Tag-Objects) -->
  532	{ http_link_to_id(show_tag, [tag(Tag)], HREF)
  533	},
  534	html(tr([td(a([class(tag),href(HREF)], Tag)),
  535		 td(\objects(Objects))
  536		])).
  537
  538objects([]) --> [].
  539objects([tag(Obj,_Time)|T]) -->
  540	object_ref(Obj, []),
  541	(   { T == [] }
  542	->  []
  543	;   html(', '),
  544	    objects(T)
  545	).
  546
  547
  548		 /*******************************
  549		 *	      MESSAGES		*
  550		 *******************************/
  551
  552:- multifile
  553	mail_notify:event_subject//1,		% +Event
  554	mail_notify:event_message//1.		% +event
  555
  556mail_notify:event_subject(tagged(Tag)) -->
  557	[ 'tagged with ~w'-[Tag] ].
  558mail_notify:event_subject(untagged(Tag)) -->
  559	[ 'removed tag ~w'-[Tag] ].
  560mail_notify:event_subject(tag_abuse) -->
  561	[ 'tag abuse'-[] ].
  562
  563
  564mail_notify:event_message(tagged(Tag)) -->
  565	[ 'tagged with "~w"'-[Tag] ].
  566mail_notify:event_message(untagged(Tag)) -->
  567	[ 'removed tag "~w"'-[Tag] ].
  568mail_notify:event_message(tag_abuse) -->
  569	[ 'tag abuse'-[] ]