7 files changed, 126 insertions(+), 7 deletions(-)

M Hearth.cabal
M i18n/en.json
M src-lib/Hearth.hs
A src-lib/Hearth/Tagging.hs
M tpl/bookmarks/index.html
M tpl/bookmarks/new.html
M tpl/index.html

@@ 62,7 62,7 @@ library
     import:           warnings
 
     -- Modules exported by the library.
-    exposed-modules:  Hearth, Hearth.TopSites
+    exposed-modules:  Hearth, Hearth.TopSites, Hearth.Tagging
 
     -- Modules included in this library but not exported.
     -- other-modules:

@@ 9,5 9,9 @@
     "Favourite": "Favourite",
     "Remove": "Remove",
     "Description": "Description",
-    "Favourites": "Favourites"
+    "Favourites": "Favourites",
+    "Tags": "Tags",
+    "Favourites tagged by:": "Favourites tagged by:",
+    "Edit page:": "Edit page:",
+    "Remove page:": "Remove page:"
 }

@@ 22,9 22,12 @@ import Data.Maybe (fromMaybe)
 import Debug.Trace (traceShow) -- For error reporting!
 
 import Hearth.TopSites
-import Network.URI (uriToString, parseAbsoluteURI)
+import Hearth.Tagging
+import Network.URI (uriToString, parseAbsoluteURI, isUnescapedInURIComponent, escapeURIString)
 import Data.Aeson (Value(..), Object, toJSON)
 import Data.List (sortOn)
+import qualified Data.Map as M
+import Data.Tuple (Solo(..))
 
 renderPage :: ByteString -> [(ByteString, Maybe ByteString)] -> [Txt.Text] ->
         [Link] -> Value -> Maybe Txt.Text


@@ 35,12 38,26 @@ renderPage path query langs hist db = case parseGingerFile resolveSource $ utf8 
     Nothing -> Nothing
   where
     ctxt :: Txt.Text -> GVal (Run SourcePos (Writer Html) Html)
-    ctxt "Q" = orderedDict [utf8' k~>v | (k, v) <- query]
+    ctxt "Q" = orderedDict [
+            utf8' k~>[v | (k', v) <- query, k' == k]
+            | (k, _) <- query
+        ]
     ctxt "D" = toGVal db
+    ctxt "tags" = list' $ reverse $ sortOn getCount [
+            orderedDict ["label"~>k, "count"~>v,
+                "selected"~>(k `elem` map utf8' tags)]
+            | (k, v) <- M.toList $ gatherTagsFromProperty "favs" db tags
+        ]
+    ctxt "alltags" = list' $ reverse $ sortOn getCount [
+            orderedDict ["label"~>k, "count"~>v]
+            | (k, v) <- M.toList $ gatherTagsFromProperty "favs" db []
+        ]
     ctxt "_" = toGVal $ translations langs
     ctxt "tops" = list' [hist2gval entry | entry <- take 20 $ topsites hist]
     ctxt "hist" = list' $ map hist2gval $ siteHistory hist
     ctxt "sortByVisits" = fromFunction sortByVisits
+    ctxt "containsAll" = fromFunction containsAll
+    ctxt "urlquery" = fromFunction $ return . toGVal . urlquery
     ctxt _ = toGVal ()
     hist2gval entry@(label, href, time) = orderedDict [
             "label"~>label,


@@ 56,6 73,23 @@ renderPage path query langs hist db = case parseGingerFile resolveSource $ utf8 
                 countVisitsPage href hist
             | otherwise = 0
     sortByVisits _ = return $ toGVal ()
+    getCount self
+        | Just get <- asLookup self, Just ret <- asNumber =<< get "count" = ret
+        | otherwise = 0
+    containsAll [(_, haystack), (_, needles)] =
+        let needles' = filter (/= "") $ map asText $ fromMaybe [] $ asList needles
+            haystack' = map asText $ fromMaybe [haystack] $ asList haystack
+        in return $ toGVal $ all (flip elem haystack') needles'
+    containsAll _ = return $ toGVal ()
+    urlquery [(_, self)] | Just self' <- asDictItems self = Txt.intercalate "&" [
+            Txt.concat [k, "=", escapeURIText $ asText v]
+            | (k, vs) <- self', v <- fromMaybe [vs] $ asList vs
+        ] where
+            escapeURIText = withString $ escapeURIString isUnescapedInURIComponent
+            withString f = Txt.pack . f . Txt.unpack
+    urlquery _ = ""
+    getQuery key = [v | (k, Just v) <- query, k == key]
+    tags = getQuery "tag"
 
 resolveSource :: FilePath -> Maybe (Maybe [Char])
 resolveSource path


@@ 109,7 143,10 @@ handleForm "/index.html" query db = return (fromMaybe "/" $ lookup "url" query, 
 handleForm "/bookmarks/read-later" query (Object db) =
     return ("/", Object $ insertConcat "readingList" (query2json query) db)
 handleForm "/bookmarks/new.html" query (Object db) =
-    return ("/", Object $ insertConcat "favs" (query2json query) db)
+    return ("/", Object $ insertConcat "favs" (query2json query) $
+            removeFav (lookup "href" query) db)
+handleForm "/bookmarks/del" query (Object db) =
+    return ("/", Object $ removeFav (lookup "href" query) db)
 handleForm path _ db = return (path, db)
 
 query2json :: [(ByteString, ByteString)] -> Value


@@ 127,3 164,13 @@ insertConcat key val = JS.insertWith prependJSON key (toJSON [val])
     prependJSON a (Array b) = Array $ V.cons a b
     prependJSON (Array a) b = Array $ V.snoc a b
     prependJSON a b = Array $ V.fromList [a, b]
+removeFav :: Maybe ByteString -> Object -> Object
+removeFav (Just href) db | Solo ret <- JS.alterF inner "favs" db = ret
+  where
+    inner (Just (Array favs)) = Solo $ Just $ toJSON $ V.filter isn'tTarget favs
+    inner (Just fav) | isn'tTarget fav = Solo $ Just fav
+    inner _ = Solo $ Nothing
+    isn'tTarget (Object record) =
+        JS.lookup "href" record /= Just (String $ utf8' href)
+    isn'tTarget _ = True
+removeFav _ db = db

@@ 0,0 1,35 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hearth.Tagging where
+
+import qualified Data.Aeson as JS
+import qualified Data.Aeson.KeyMap as JS
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Data.Vector as V
+
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.ByteString (ByteString)
+
+import Data.Maybe (fromMaybe)
+
+gatherTagsFromProperty :: JS.Key -> JS.Value -> [ByteString] -> M.Map Text Int
+gatherTagsFromProperty k (JS.Object db) tags =
+    gatherTags tags $ fromMaybe JS.Null $ JS.lookup k db
+gatherTagsFromProperty _ _ _ = M.empty
+
+gatherTags :: [ByteString] -> JS.Value -> M.Map Text Int
+gatherTags ts (JS.Array db) = M.unionsWith (+) $ map (getTags ts) $ V.toList db
+gatherTags _ _ = M.empty
+
+getTags :: [ByteString] -> JS.Value -> M.Map Text Int
+getTags tags (JS.Object db)
+    | Just (JS.Array v) <- JS.lookup "tags" db =
+        let ret = M.fromListWith (+) [(t, 1) | JS.String t <- V.toList v, t /= ""]
+        in if S.fromList (map decodeUtf8 tags) `S.isSubsetOf` M.keysSet ret
+        then ret else M.empty
+    -- Handle singleton representation.
+    | Just (JS.String t) <- JS.lookup "tags" db, [] <- tags, t /= "" = M.singleton t 1
+    | Just (JS.String t) <- JS.lookup "tags" db, [t'] <- tags, t == decodeUtf8 t',
+            t /= "" = M.singleton t 1
+getTags _ _ = M.empty

@@ 6,9 6,29 @@
 </head>
 <body>
   <h1>⭐️{{ _["Favourites"] }}</h1>
+  <aside>{% for tag in tags %}
+    {% if tag.selected %}
+      <strong>
+        <a href="?{% for x in Q.tag %}{% if x != tag.label %}tag={{ x|urlencode }}&{% endif %}{% endfor %}"
+            style="font-size: {{ tag.count }}em">{{ tag.label }}</a></strong>
+    {% else %}
+      <a href="?{{ Q|urlquery }}&tag={{ tag.label|urlencode }}"
+        style="font-size: {{ tag.count }}em">{{ tag.label }} ({{ tag.count }})</a>
+    {% endif %}
+  {% endfor %}</aside>
+
   <dl>{% for fav in D.favs|sortByVisits %}
-    <dt><a href="{{ fav.href }}" title="{{ fav.title }}">{{ fav.label }}</a></dt>
-    <dd>{{ fav.title }}</dd>
+    {% if fav.tags|containsAll(Q.tag) %}
+      <dt>
+        <a href="{{ fav.href }}" title="{{ fav.title }}">{{ fav.label }}</a> |
+        <a href="new.html?{{ fav|urlquery }}"
+            title="{{ _['Edit page:'] }} {{ fav.label }}">✏️</a> |
+        <form action="del" method="POST" style="display: inline">
+          <button name="href" value="{{ fav.href }}"
+                title="{{ _['Remove page:'] }} {{ fav.label }}">❌️</button>
+        </form></dt>
+      <dd>{{ fav.title }}</dd>
+    {% endif %}
   {% endfor %}</dl>
 </body>
 </html>

@@ 13,6 13,11 @@
     <dd><input type="url" name="href" value="{{ Q.href }}" required id="input-url" /></dd>
     <dt><label for="input-title">{{ _["Description"] }}</label></dt>
     <dd><textarea id="input-title" name="title"></textarea></dd>
+    <dt><label for="input-tags">📑️{{ _["Tags"] }}</label></dt>
+    <dd><select name="tags" id="input-tags" multiple>{% for tag in alltags %}
+      <option {% if tag.label|in(Q.tags) %}selected{% endif %}>{{ tag.label }}</option>
+    {% endfor %}</select></dd>
+    <dd><label>New tag<input name="tags" /></label></dd>
   </dl>
   <p><button type="submit" formaction="read-later">📚️{{ _["Read Later"] }}</button>
     <!-- TODO: Implement these! -->

@@ 27,6 27,14 @@
         <li><a href="{{ link.href }}" title="{{ link.title }}">{{ link.label }}</a></li>
       {% endfor %}</ul>
     </section>{% endif %}
+    {% if tags %}<section>
+      <h1>📑️{{ _["Tags"] }}</h1>
+      <ul>{% for tag in alltags|slice(0, 20) %}
+        <li><a href="/bookmarks/?tag={{ tag.label|urlencode }}"
+            title="{{ _['Favourites tagged by:' ] }} {{ tag}}">{{ tag.label }}</a>
+          {{ tag.count }}</li>
+      {% endfor %}</ul>
+    </section>{% endif %}
   </main>
 </body>
 </html>