Tags.hs

{-
Copyright (C) 2013 John Lenz <lenz@math.uic.edu>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program 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.  See the
GNU Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}
module Handler.Tags(
    tagHeader
  , tagWidget
  , postRetagThreadR
  , postRetagMessageR
) where

import Import
import Settings
import qualified Data.Text as T

import NotmuchCmd

displayTag :: T.Text -> GWidget s App ()
displayTag "unread" = [whamlet|<span .label .label-important .label-tag>unread|]
displayTag t = [whamlet|<span .label .label-info .label-tag>#{t}|]

-- | A widget consisting of the retag buttons followed by the current tag list.
tagWidget :: Either SearchResult Message -> GWidget s App ()
tagWidget x = do
  let url = case x of
              Left s -> RetagThreadR (searchThread s)
              Right m -> RetagMessageR (messageId m)

  let tags = either searchTags messageTags x

  retags <- extraRetag <$> lift getExtra
  [whamlet|
<span .tags>
    <div .btn-group>
        $forall r <- retags
            <button .btn .retag-button .btn-link title="#{retagName r}" data-notmuch-url="@{url (retagName r)}">
                <i class="#{retagIcon r}">
    $forall tag <- tags
        ^{displayTag tag}
|]

-- | When posting to retag routes, the thread and retag information
-- is avaialble in the route but we also want a CSRF token to protect
-- against CSRF attacks.  Therefore the body of the post contains
-- an empty form (internally Yesod includes the CSRF token for us).
retagForm :: Form ()
retagForm = renderDivs $ pure ()

-- | A widget that contains the support elements for retagging, including the forms
-- and javascript.  This widget must be included only ONCE in the page.  A notmuch:retag
-- event is raised after a successful retag.
tagHeader :: Widget
tagHeader = do
    (widget,enctype) <- lift $ generateFormPost retagForm
    [whamlet|
<form #retag-csrf-form enctype=#{enctype} style="display:none">
    ^{widget}
|]

    toWidget [julius|
$(document).on("click", ".retag-button", function() {
  var tagspan = $(this).parents("span.tags");
  var retagform = $("#retag-csrf-form");

  $.ajax({
      type: 'POST',
      data: retagform.serialize(),
      dataType: 'json',
      url: $(this).data('notmuch-url')
  })
  .done(function(data) {
      tagspan.children("span").each(function(idx, elem) {
          if ($.inArray(elem.textContent, data.remove) >= 0) {
              $(elem).remove();
          }
          var i = $.inArray(elem.textContent, data.add);
          if (i >= 0) {
            data.add.splice(i, 1);
          }
      });
      $.each(data.add, function(idx, tag) {
          tagspan.append(" <span class='label label-info label-tag'>" + tag + "</span> ");
      });
      tagspan.trigger("notmuch:retag", data);
  })
  .fail(function(xhr, err, e) {
      alert("Error " + err + " " + e);
  });
});
|]

postRetagThreadR :: ThreadID -> T.Text -> Handler RepJson
postRetagThreadR t name = do
    ((result,_),_) <- runFormPost retagForm
    case result of
        FormMissing -> invalidArgs ["form is missing"]
        FormFailure msg -> invalidArgs msg
        FormSuccess _ -> return ()

    retags <- extraRetag <$> getExtra
    let retag = filter (\r -> retagName r == name) retags
    case retag of
        [] -> notFound
        (r:_) -> do notmuchTagThread (retagAdd r) (retagRemove r) t
                    jsonToRepJson r

postRetagMessageR :: MessageID -> T.Text -> Handler RepJson
postRetagMessageR m name = do
    ((result,_),_) <- runFormPost retagForm
    case result of
        FormMissing -> invalidArgs ["form is missing"]
        FormFailure msg -> invalidArgs msg
        FormSuccess _ -> return ()

    retags <- extraRetag <$> getExtra
    let retag = filter (\r -> retagName r == name) retags
    case retag of
        [] -> notFound
        (r:_) -> do notmuchTagMessage (retagAdd r) (retagRemove r) m
                    jsonToRepJson r