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