From 4e15670910c6c8993103edc00b23f240b170cfa1 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 12 Jan 2024 16:10:05 +1300
Subject: [PATCH] Upload missing files, implement TopSites backend!

---
 Hearth.cabal                |  4 +--
 i18n/en.json                |  4 +++
 src-lib/Hearth.hs           | 64 +++++++++++++++++++++++++++++++++++++
 src-lib/Hearth/TopSites.hs  | 27 ++++++++++++++++
 src-lib/Hearth/TopSites.hs~ |  1 +
 5 files changed, 98 insertions(+), 2 deletions(-)
 create mode 100644 i18n/en.json
 create mode 100644 src-lib/Hearth.hs
 create mode 100644 src-lib/Hearth/TopSites.hs
 create mode 100644 src-lib/Hearth/TopSites.hs~

diff --git a/Hearth.cabal b/Hearth.cabal
index 5fd6567..ac0daf9 100644
--- a/Hearth.cabal
+++ b/Hearth.cabal
@@ -62,7 +62,7 @@ library
     import:           warnings
 
     -- Modules exported by the library.
-    exposed-modules:  Hearth
+    exposed-modules:  Hearth, Hearth.TopSites
 
     -- Modules included in this library but not exported.
     -- other-modules:
@@ -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
+        file-embed, mtl, filepath, aeson, containers, network-uri
 
     -- Directories containing source files.
     hs-source-dirs:   src-lib
diff --git a/i18n/en.json b/i18n/en.json
new file mode 100644
index 0000000..0253c58
--- /dev/null
+++ b/i18n/en.json
@@ -0,0 +1,4 @@
+{
+    "Homepage": "Homepage",
+    "Web Address": "Web Address"
+}
diff --git a/src-lib/Hearth.hs b/src-lib/Hearth.hs
new file mode 100644
index 0000000..4fd7cdd
--- /dev/null
+++ b/src-lib/Hearth.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
+module Hearth (renderPage, handleForm) where
+
+import Text.Ginger.Parse (parseGingerFile, SourcePos)
+import Text.Ginger.Run (runGinger, makeContextHtml, Run)
+import Text.Ginger.Html (htmlSource, Html)
+import Text.Ginger.GVal as V (toGVal, orderedDict, (~>), GVal)
+import Control.Monad.Writer.Lazy (Writer)
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text as Txt
+import qualified Data.Text.Encoding as Txt
+import Data.FileEmbed
+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
+    Just (Right tpl) -> do
+      Just $ htmlSource $ flip runGinger tpl $ makeContextHtml ctxt
+    Just (Left err) -> traceShow err Nothing
+    Nothing -> Nothing
+  where
+    ctxt :: Txt.Text -> GVal (Run SourcePos (Writer Html) Html)
+    ctxt "Q" = orderedDict [utf8' k~>v | (k, v) <- query]
+    ctxt "_" = toGVal $ translations langs
+    ctxt _ = toGVal ()
+
+resolveSource :: FilePath -> Maybe (Maybe [Char])
+resolveSource path
+    | ret@(Just _) <- resolveSource' path = Just ret
+    | ret@(Just _) <- resolveSource' (path </> "index.html") = Just ret
+    | otherwise = Nothing
+resolveSource' :: FilePath -> Maybe [Char]
+resolveSource' = fmap utf8 .
+    flip lookup $(makeRelativeToProject "tpl" >>= embedDir) . tail . normalise
+
+-- | Convert from UTF-8 bytestring to a string.
+utf8 :: ByteString -> String
+utf8 = Txt.unpack . Txt.decodeUtf8
+utf8' :: ByteString -> Txt.Text
+utf8' = Txt.decodeUtf8
+
+translations :: [Txt.Text] -> JS.Value
+translations (lang:langs)
+    | Just file <- lookup (Txt.unpack lang ++ ".json") files,
+        Just ret <- JS.decode $ LBS.fromStrict file = ret
+    | otherwise = translations langs
+  where files = $(makeRelativeToProject "i18n" >>= embedDir)
+translations [] = JS.Null
+
+------
+--- Interactive features
+------
+
+handleForm :: ByteString -> [(ByteString, ByteString)] -> IO ByteString
+handleForm "/" query = return $ fromMaybe "/" $ lookup "url" query
+handleForm "/index.html" query = return $ fromMaybe "/" $ lookup "url" query
+handleForm path _ = return path
diff --git a/src-lib/Hearth/TopSites.hs b/src-lib/Hearth/TopSites.hs
new file mode 100644
index 0000000..7c69441
--- /dev/null
+++ b/src-lib/Hearth/TopSites.hs
@@ -0,0 +1,27 @@
+module Hearth.TopSites (topsites) where
+
+import qualified Data.Set as S
+import Network.URI (URI)
+import Data.List (sortOn)
+
+type Link = (String, URI)
+-- | 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
+
+rankSite :: [Link] -> URI -> (Int, Link)
+rankSite sites site
+    | _:_ <- sites' = (sum $ map fst sites', snd $ head sites')
+    | otherwise = (0, ("", site)) -- *shouldn't* happen...
+  where
+    sites' = [(i, x) | (i, x@(_, u)) <- indexed sites, u == site]
+    indexed l = reverse [1..length l] `zip` l
+
+-- | 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
diff --git a/src-lib/Hearth/TopSites.hs~ b/src-lib/Hearth/TopSites.hs~
new file mode 100644
index 0000000..a08c671
--- /dev/null
+++ b/src-lib/Hearth/TopSites.hs~
@@ -0,0 +1 @@
+module Hearth.TopSites
-- 
2.30.2