From ad72934e6b720b68ecba478e737a5237b5b57513 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 16 Jan 2024 15:53:28 +1300 Subject: [PATCH] Add a topsites listing with history page --- Hearth.cabal | 2 +- app/Main.hs | 2 +- i18n/en.json | 3 ++- src-lib/Hearth.hs | 23 ++++++++++++++++++++--- src-lib/Hearth/TopSites.hs | 26 ++++++++++++++++++++------ tpl/history.html | 15 +++++++++++++++ tpl/index.html | 9 +++++++++ 7 files changed, 68 insertions(+), 12 deletions(-) create mode 100644 tpl/history.html diff --git a/Hearth.cabal b/Hearth.cabal index ac0daf9..7d917ef 100644 --- a/Hearth.cabal +++ b/Hearth.cabal @@ -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 diff --git a/app/Main.hs b/app/Main.hs index f27e612..742d26c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/i18n/en.json b/i18n/en.json index 0253c58..ee53dd4 100644 --- a/i18n/en.json +++ b/i18n/en.json @@ -1,4 +1,5 @@ { "Homepage": "Homepage", - "Web Address": "Web Address" + "Web Address": "Web Address", + "History": "History" } diff --git a/src-lib/Hearth.hs b/src-lib/Hearth.hs index 4fd7cdd..68af727 100644 --- a/src-lib/Hearth.hs +++ b/src-lib/Hearth.hs @@ -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 ------ diff --git a/src-lib/Hearth/TopSites.hs b/src-lib/Hearth/TopSites.hs index 7c69441..e69ed33 100644 --- a/src-lib/Hearth/TopSites.hs +++ b/src-lib/Hearth/TopSites.hs @@ -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' diff --git a/tpl/history.html b/tpl/history.html new file mode 100644 index 0000000..b4400a9 --- /dev/null +++ b/tpl/history.html @@ -0,0 +1,15 @@ + + + + + ⏳️{{ _["History"] }} + + +

⏳️{{ _["History"] }} + +
{% for entry in hist %} +
{{ entry.time }}
+
{{ entry.label }}
+ {% endfor %}
+ + diff --git a/tpl/index.html b/tpl/index.html index 8c0eaba..14bd94d 100644 --- a/tpl/index.html +++ b/tpl/index.html @@ -8,4 +8,13 @@

+
+
+

⏳️{{ _["History"] }}

+ +
+
+ -- 2.30.2