7 files changed, 68 insertions(+), 12 deletions(-)

M Hearth.cabal
M app/Main.hs
M i18n/en.json
M src-lib/Hearth.hs
M src-lib/Hearth/TopSites.hs
A tpl/history.html
M tpl/index.html

@@ 72,7 72,7 @@ library
 
     -- Other library packages from which modules are imported.
     build-depends:    base ^>=4.17.0.0, ginger>0.10 && <1, bytestring, text,
-        file-embed, mtl, filepath, aeson, containers, network-uri
+        file-embed, mtl, filepath, aeson, containers, network-uri, time
 
     -- Directories containing source files.
     hs-source-dirs:   src-lib

@@ 21,7 21,7 @@ main = do
 
 servePage :: Application
 servePage req respond = case requestMethod req of
-  "GET" | Just resp <- renderPage (rawPathInfo req) (queryString req) (headerAcceptLang req) ->
+  "GET" | Just resp <- renderPage (rawPathInfo req) (queryString req) (headerAcceptLang req) [] ->
     respond $ responseLBS status200 [] $ LTxt.encodeUtf8 $ fromStrict resp
   "POST" -> do
     (query, _) <- parseRequestBodyEx defaultParseRequestBodyOptions lbsBackEnd req

@@ 1,4 1,5 @@
 {
     "Homepage": "Homepage",
-    "Web Address": "Web Address"
+    "Web Address": "Web Address",
+    "History": "History"
 }

@@ 16,11 16,14 @@ import System.FilePath (normalise, (</>))
 
 import qualified Data.Aeson as JS
 import Data.Maybe (fromMaybe)
-
 import Debug.Trace (traceShow) -- For error reporting!
 
-renderPage :: ByteString -> [(ByteString, Maybe ByteString)] -> [Txt.Text] -> Maybe Txt.Text
-renderPage path query langs = case parseGingerFile resolveSource $ utf8 path of
+import Hearth.TopSites
+import Network.URI (uriToString)
+
+renderPage :: ByteString -> [(ByteString, Maybe ByteString)] -> [Txt.Text] -> [Link]
+        -> Maybe Txt.Text
+renderPage path query langs hist = case parseGingerFile resolveSource $ utf8 path of
     Just (Right tpl) -> do
       Just $ htmlSource $ flip runGinger tpl $ makeContextHtml ctxt
     Just (Left err) -> traceShow err Nothing


@@ 29,7 32,14 @@ renderPage path query langs = case parseGingerFile resolveSource $ utf8 path of
     ctxt :: Txt.Text -> GVal (Run SourcePos (Writer Html) Html)
     ctxt "Q" = orderedDict [utf8' k~>v | (k, v) <- query]
     ctxt "_" = toGVal $ translations langs
+    ctxt "tops" = list' [hist2gval entry | entry <- take 20 $ topsites hist]
+    ctxt "hist" = list' $ map hist2gval $ siteHistory hist
     ctxt _ = toGVal ()
+    hist2gval entry@(label, href, time) = orderedDict [
+            "label"~>label,
+            "href"~>uriToString id href "",
+            "time"~>time,
+            "count"~>countVisits entry hist]
 
 resolveSource :: FilePath -> Maybe (Maybe [Char])
 resolveSource path


@@ 50,10 60,17 @@ translations :: [Txt.Text] -> JS.Value
 translations (lang:langs)
     | Just file <- lookup (Txt.unpack lang ++ ".json") files,
         Just ret <- JS.decode $ LBS.fromStrict file = ret
+    | "-" `Txt.isInfixOf` lang = let (lang', _) = Txt.breakOn "-" lang
+        in translations (lang':langs)
     | otherwise = translations langs
   where files = $(makeRelativeToProject "i18n" >>= embedDir)
 translations [] = JS.Null
 
+-- | Type-constrained conversion of a list to Ginger's datamodel,
+-- serves to avoid type-inference issues.
+list' :: [GVal m] -> GVal m
+list' = toGVal
+
 ------
 --- Interactive features
 ------

@@ 1,27 1,41 @@
-module Hearth.TopSites (topsites) where
+module Hearth.TopSites (topsites, Link, siteHistory, countVisits) where
 
 import qualified Data.Set as S
-import Network.URI (URI)
+import Data.Containers.ListUtils (nubOrdOn)
+import Network.URI (URI(..), nullURI, relativeTo)
 import Data.List (sortOn)
 
-type Link = (String, URI)
+import Data.Time.LocalTime (ZonedTime)
+
+type Link = (String, URI, ZonedTime)
+link (_, ret, _) = ret
 -- | Takes a reverse-chronologically-sorted list of labled links & hueristically
 -- reorders them by weighted-frequency.
 topsites :: [Link] -> [Link]
 topsites = map snd . sortOn fst . rankSites
 
 rankSites :: [Link] -> [(Int, Link)]
-rankSites sites = map (rankSite sites) $ nub' $ map snd sites
+rankSites sites = map (rankSite sites) $ nub' $ map link sites
 
 rankSite :: [Link] -> URI -> (Int, Link)
 rankSite sites site
     | _:_ <- sites' = (sum $ map fst sites', snd $ head sites')
-    | otherwise = (0, ("", site)) -- *shouldn't* happen...
+    | otherwise = (0, ("", site, epoch)) -- *shouldn't* happen...
   where
-    sites' = [(i, x) | (i, x@(_, u)) <- indexed sites, u == site]
+    sites' = [(i, x) | (i, x@(_, u, _)) <- indexed sites, u == site]
     indexed l = reverse [1..length l] `zip` l
+    epoch = read "1970-01-01 00:00:00 UTC" -- Placeholder value!
 
 -- | Removes duplicate elements from a list in O(nlogn) time. In particular,
 -- it keeps only the first occurrence of each element. (The name nub means `essence'.)
 nub' :: Ord a => [a] -> [a]
 nub' = S.toList . S.fromList
+
+siteHistory :: [Link] -> [Link]
+siteHistory = nubOrdOn link . map inner
+    where inner (_, u, t) =
+            (show $ uriAuthority u, nullURI { uriPath = "/" } `relativeTo` u, t)
+
+countVisits :: Link -> [Link] -> Int
+countVisits (_, page, _) = length . filter inner
+    where inner (_, page', _) = uriAuthority page == uriAuthority page'

@@ 0,0 1,15 @@
+<!DOCTYPE html>
+<html>
+<head>
+  <meta charset=utf-8 />
+  <title>⏳️{{ _["History"] }}</title>
+</head>
+<body>
+  <h1>⏳️{{ _["History"] }}</title>
+  <!-- NOTE: Only contains unique domains, to differentiate from other history views -->
+  <dl>{% for entry in hist %}
+    <dt>{{ entry.time }}</dt> <!-- TODO: Deduplicate! -->
+    <dd><a href="{{ entry.href }}">{{ entry.label }}</a></dd>
+  {% endfor %}</dl>
+</body>
+</html>

@@ 8,4 8,13 @@
   <form method="POST">
     <p><input type="url" name="url" placeholder="{{ _['Web Address'] }}" required /></p>
   </form>
+  <main>
+    <section>
+      <h1><a href="history.html">⏳️{{ _["History"] }}</a></h1>
+      <ul>{% for topsite in tops %}
+        <li><a href="{{ topsite.href }}">{{ topsite.label }}</a></li>
+      {% endfor %}</ul>
+    </section>
+  </main>
 </body>
+</html>