Implement basic tagging (closes #16)

Data/Slug.hs

@@ -1,6 +1,7 @@
 module Data.Slug
     ( Slug
     , mkSlug
+    , mkSlugLen
     , safeMakeSlug
     , unSlug
     , InvalidSlugException (..)
@@ -30,6 +31,14 @@ mkSlug t
     | otherwise = return $ Slug t
   where
 
+mkSlugLen :: MonadThrow m => Int -> Int -> Text -> m Slug
+mkSlugLen minLen maxLen t
+    | length t < minLen = throwM $ InvalidSlugException t "Too short"
+    | length t > maxLen = throwM $ InvalidSlugException t "Too long"
+    | any (not . validChar) t = throwM $ InvalidSlugException t "Contains invalid characters"
+    | "-" `isPrefixOf` t = throwM $ InvalidSlugException t "Must not start with a hyphen"
+    | otherwise = return $ Slug t
+
 minLen, maxLen :: Int
 minLen = 3
 maxLen = 30

Handler/Package.hs

@@ -5,6 +5,7 @@
 module Handler.Package where
 
 import           Data.Char
+import           Data.Slug
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import           Data.Time (addUTCTime)
@@ -44,6 +45,12 @@ getPackageR pn = do
 
         return (packages, downloads, recentDownloads, nLikes, liked, metadata)
 
+    tags <- fmap (map (\(E.Value v) -> v))
+                 (runDB (E.selectDistinct
+                             (E.from (\t -> do E.where_ (t ^. TagPackage E.==. E.val pn)
+                                               E.orderBy [E.asc (t ^. TagTag)]
+                                               return (t ^. TagTag)))))
+
     let likeTitle = if liked
                        then "You liked this!"
                        else "I like this!" :: Text
@@ -63,8 +70,6 @@ getPackageR pn = do
             ])
         $(widgetFile "package")
   where enumerate = zip [0::Int ..]
-        tags = ["web","framework","library","stable","maintained","potato"] :: [Text]
-
         reformat (Value version, Value title, Value ident, Value hasHaddocks) =
             (version,fromMaybe title (stripPrefix "Stackage build for " title),ident,hasHaddocks)
 
@@ -178,3 +183,17 @@ postPackageUnlikeR name = maybeAuthId >>= \muid -> case muid of
         E.where_ $ like ^. LikePackage E.==. E.val name
                &&. like ^. LikeVoter E.==. E.val uid
       return ()
+
+postPackageTagR :: PackageName -> Handler ()
+postPackageTagR packageName =
+  maybeAuthId >>=
+  \muid ->
+    case muid of
+      Nothing -> return ()
+      Just uid ->
+        do mtag <- lookupPostParam "slug"
+           case mtag of
+             Just tag ->
+               do slug <- mkSlugLen 1 20 tag
+                  void (runDB (P.insert (Tag packageName slug uid)))
+             Nothing -> error "Need a slug"

config/routes

@@ -29,3 +29,4 @@
 /compressor-status CompressorStatusR GET
 /package/#PackageName/like PackageLikeR POST
 /package/#PackageName/unlike PackageUnlikeR POST
+/package/#PackageName/tag PackageTagR POST

templates/package.hamlet

@@ -18,18 +18,23 @@ $newline never
                 <a href="https://plus.google.com/share?url=https://www.fpcomplete.com/user/chrisdonefp/example-autorun-active" target="_blank">
                     <i class="fa-google-plus-square fa">
             <div .tags>
+                $if null tags
+                    <span .no-tags>
+                        No tags yet. #
                 $forall tag <- tags
                     <span .tag>
-                        <a href="javascript:alert('Patience, preciouses!')">
+                        <a>
                             #{tag}
                         , #
-                <i class="fa fa-plus-square" onclick="document.getElementById('add-tag-form').className = ''"></i>
+                <i #add-tag class="fa fa-plus-square" title="Show/hide tag form">
                 <form #add-tag-form .hidden>
                     <p>
                         <strong>Add tag
                     <div .input-append>
                         <input type="text" id="new-tag">
-                        <button .btn>Add
+                        <input type="submit" .btn #add-form-btn value="Confirm">
+                    <p #tag-msg .alert .alert-error style="display:none">
+
             <div .social>
                 <span #likes>
                     #{nLikes}

templates/package.julius

@@ -1,4 +1,8 @@
 $(function(){
+  var tags = Object.create(null);
+  $('.tags').find('.tag').each(function(){
+    tags[$(this).find('a').text()] = true;
+  });
   $('.expanding').each(function(){
     var $this = $(this);
     if ($this.height() > 300) {
@@ -38,4 +42,66 @@ $(function(){
       window.location.href = '@{AuthR LoginR}';
     }
   });
+  $('#add-tag').click(function(){
+    $('#add-tag-form').toggleClass('hidden');
+    $('#new-tag').focus();
+  });
+  $('#new-tag').change(function(){
+    $('#add-form-btn').val('Confirm');
+    $('#tag-msg').hide();
+  });
+  $('#new-tag').keypress(function(){
+    $('#add-form-btn').val('Confirm');
+  });
+  $('#add-tag-form').submit(function(){
+    try {
+      var candidate = $('#new-tag').val();
+      var normalized = candidate
+        .replace(/[^a-zA-Z0-9-.]/g,'-')
+        .replace(/-+/g,'-')
+        .replace(/^-/,'')
+        .replace(/-$/,'')
+        .toLowerCase();
+      if (candidate !== normalized) {
+        $('#new-tag').val(normalized);
+        $('#add-form-btn').val('Done');
+      } else {
+        $.ajax({
+          method: 'POST',
+          url: '@{PackageTagR pn}',
+          data: {slug:normalized},
+          success: function(){
+
+          $('.no-tags').remove();
+
+          $('#new-tag').val('');
+          $('#add-form-btn').val('Confirm');
+
+          if (!tags[normalized]) {
+            var tag = $('<span><a></a></span>');
+            tag.find('a').text(normalized);
+            $('.tags').prepend(', ');
+            $('.tags').prepend(tag);
+          }
+
+          tags[normalized] = true;
+        },
+          error: function(err){
+            $('#tag-msg').text('invalid slug; too short or too long').show();
+        }
+        });
+      }
+    } finally {
+      return false;
+    }
+  });
 });
+
+// Workaround for missing functionality in IE 8 and earlier.
+if( Object.create === undefined ) {
+  Object.create = function( o ) {
+    function F(){}
+    F.prototype = o;
+    return new F();
+  };
+}

templates/package.lucius

@@ -188,3 +188,7 @@ h2.changes-title {
     display: block;
   }
 }
+
+.no-tags {
+  color: #888;
+}