From 3871d4b028cb9d1cf35050a711ad6d6de8a3c4f5 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 19 Jan 2024 15:29:26 +1300 Subject: [PATCH] Add reading-list support! --- Hearth.cabal | 6 ++-- app/Main.hs | 58 ++++++++++++++++++++++++++++++-------- i18n/en.json | 9 +++++- src-lib/Hearth.hs | 51 +++++++++++++++++++++++++++------ src-lib/Hearth/TopSites.hs | 1 + tpl/index.html | 10 +++++-- 6 files changed, 109 insertions(+), 26 deletions(-) diff --git a/Hearth.cabal b/Hearth.cabal index 7d917ef..45196ed 100644 --- a/Hearth.cabal +++ b/Hearth.cabal @@ -52,7 +52,7 @@ build-type: Simple extra-doc-files: CHANGELOG.md -- Extra source files to be distributed with the package, such as examples, or a tutorial module. -extra-source-files: tpl/**.html, i18n/*.json +extra-source-files: tpl/**.html, i18n/*.json, history.tsv common warnings ghc-options: -Wall @@ -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, time + file-embed, mtl, filepath, aeson, containers, network-uri, time, vector -- Directories containing source files. hs-source-dirs: src-lib @@ -96,7 +96,7 @@ executable Hearth -- Other library packages from which modules are imported. build-depends: base ^>=4.17.0.0, - Hearth, + Hearth, file-embed, time, network-uri, aeson, directory, warp >= 3.3.31 && < 3.4, wai >= 3.2.3 && < 3.3, wai-extra >= 3.1 && < 4, http-types >= 0.12.3 && < 0.13, text >= 2.0.1 && < 2.1, bytestring >= 0.11 && < 1 diff --git a/app/Main.hs b/app/Main.hs index 742d26c..ac145c2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} module Main where import Network.Wai.Handler.Warp @@ -10,24 +10,46 @@ import Data.Text.Lazy (fromStrict) import qualified Data.Text as Txt import qualified Data.Text.Lazy.Encoding as LTxt import Data.Text.Encoding (decodeUtf8) -import Data.ByteString (ByteString) +import Data.ByteString (ByteString, stripPrefix) import Data.Maybe (fromMaybe) -import Hearth (renderPage, handleForm) +import Data.FileEmbed +import Data.Char (isSpace) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import Network.URI (parseURIReference) +import Data.Maybe (mapMaybe) + +import Data.Aeson (decodeFileStrict, encodeFile, Value(..)) +import qualified System.Directory as Dir + +import Hearth (renderPage, handleForm, markAsRead, Link, utf8) main :: IO () main = do + putStrLn "http://127.0.0.1:2019/" runEnv 2019 servePage +dbFile :: FilePath +dbFile = "hearth.json" + servePage :: Application -servePage req respond = case requestMethod req of - "GET" | Just resp <- renderPage (rawPathInfo req) (queryString req) (headerAcceptLang req) [] -> - respond $ responseLBS status200 [] $ LTxt.encodeUtf8 $ fromStrict resp - "POST" -> do - (query, _) <- parseRequestBodyEx defaultParseRequestBodyOptions lbsBackEnd req - redirect <- handleForm (rawPathInfo req) query - respond $ responseLBS status301 [(hLocation, redirect)] "" - _ -> respond $ responseLBS status404 [] "Page not found!" +servePage req respond = do + hasDB <- Dir.doesFileExist dbFile + db <- if hasDB then decodeFileStrict dbFile else return Nothing + let db' = fromMaybe Null db + case requestMethod req of + "GET" | Just dest <- stripPrefix "/read/" $ rawPathInfo req -> do + encodeFile dbFile $ markAsRead dest db' + respond $ responseLBS status301 [(hLocation, dest)] "" + | Just resp <- renderPage (rawPathInfo req) (queryString req) + (headerAcceptLang req) history db' -> + respond $ responseLBS status200 [] $ LTxt.encodeUtf8 $ fromStrict resp + "POST" -> do + (query, _) <- parseRequestBodyEx defaultParseRequestBodyOptions lbsBackEnd req + (redirect, dbNew) <- handleForm (rawPathInfo req) query db' + encodeFile dbFile dbNew + respond $ responseLBS status301 [(hLocation, redirect)] "" + _ -> respond $ responseLBS status404 [] "Page not found!" headerAcceptLang :: Request -> [Txt.Text] headerAcceptLang = parseAcceptLang . lookup hAcceptLanguage . requestHeaders @@ -35,4 +57,16 @@ parseAcceptLang :: Maybe ByteString -> [Txt.Text] parseAcceptLang = map dropParam . Txt.splitOn "," . decodeUtf8 . fromMaybe "en" where dropParam = Txt.takeWhile (/= ';') - +history :: [Link] +history = mapMaybe parseLine $ lines $ + utf8 $(makeRelativeToProject "history.tsv" >>= embedFile) + where + stripL = dropWhile isSpace + parseLine line | '#':_ <- stripL line = Nothing + | [] <- stripL line = Nothing + | Just url' <- parseURIReference url, + Just date' <- iso8601ParseM date = Just (title, url', date') + | otherwise = Nothing + where + (url, titleDate) = break (== '\t') line + (title, date) = break (== '\t') titleDate diff --git a/i18n/en.json b/i18n/en.json index ee53dd4..6dcb085 100644 --- a/i18n/en.json +++ b/i18n/en.json @@ -1,5 +1,12 @@ { "Homepage": "Homepage", "Web Address": "Web Address", - "History": "History" + "History": "History", + "Name": "Name", + "Reading List": "Reading List", + "Add Bookmark": "Add Bookmark", + "Read Later": "Read Later", + "Favourite": "Favourite", + "Remove": "Remove", + "Description": "Description" } diff --git a/src-lib/Hearth.hs b/src-lib/Hearth.hs index 68af727..b78a9e5 100644 --- a/src-lib/Hearth.hs +++ b/src-lib/Hearth.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -module Hearth (renderPage, handleForm) where +module Hearth (renderPage, handleForm, markAsRead, utf8, Link) where import Text.Ginger.Parse (parseGingerFile, SourcePos) import Text.Ginger.Run (runGinger, makeContextHtml, Run) @@ -15,15 +15,19 @@ import Data.FileEmbed import System.FilePath (normalise, ()) import qualified Data.Aeson as JS +import qualified Data.Aeson.KeyMap as JS +import qualified Data.Vector as V +import Data.String (fromString) import Data.Maybe (fromMaybe) import Debug.Trace (traceShow) -- For error reporting! import Hearth.TopSites import Network.URI (uriToString) +import Data.Aeson (Value(..), Object, toJSON) -renderPage :: ByteString -> [(ByteString, Maybe ByteString)] -> [Txt.Text] -> [Link] - -> Maybe Txt.Text -renderPage path query langs hist = case parseGingerFile resolveSource $ utf8 path of +renderPage :: ByteString -> [(ByteString, Maybe ByteString)] -> [Txt.Text] -> + [Link] -> Value -> Maybe Txt.Text +renderPage path query langs hist db = case parseGingerFile resolveSource $ utf8 path of Just (Right tpl) -> do Just $ htmlSource $ flip runGinger tpl $ makeContextHtml ctxt Just (Left err) -> traceShow err Nothing @@ -31,6 +35,7 @@ renderPage path query langs hist = case parseGingerFile resolveSource $ utf8 pat where ctxt :: Txt.Text -> GVal (Run SourcePos (Writer Html) Html) ctxt "Q" = orderedDict [utf8' k~>v | (k, v) <- query] + ctxt "D" = toGVal db ctxt "_" = toGVal $ translations langs ctxt "tops" = list' [hist2gval entry | entry <- take 20 $ topsites hist] ctxt "hist" = list' $ map hist2gval $ siteHistory hist @@ -75,7 +80,37 @@ list' = toGVal --- 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 +markAsRead :: ByteString -> Value -> Value +markAsRead dest Null = markAsRead dest $ Object $ JS.empty +markAsRead dest (Object db) = Object $ JS.insert "readingList" readingList' db + where + readingList' | Just (Array list) <- JS.lookup "readingList" db = + toJSON $ V.filter isn'tDest list + | otherwise = Array V.empty + isn'tDest (Object record) = JS.lookup "href" record /= Just (String $ utf8' dest) + isn'tDest _ = True +markAsRead _ db = db + +handleForm :: ByteString -> [(ByteString, ByteString)] -> Value -> IO (ByteString, Value) +handleForm path query Null = handleForm path query $ Object $ JS.empty +handleForm "/" query db = return (fromMaybe "/" $ lookup "url" query, db) +handleForm "/index.html" query db = return (fromMaybe "/" $ lookup "url" query, db) +handleForm "/bookmarks/read-later" query (Object db) = + return ("/", Object $ insertConcat "readingList" (query2json query) db) +handleForm path _ db = return (path, db) + +query2json :: [(ByteString, ByteString)] -> Value +query2json query = Object $ JS.fromListWith gatherArray + [(fromString $ utf8 k, toJSON $ utf8 v) | (k, v) <- query] + where + gatherArray (Array a) (Array b) = Array $ b V.++ a + gatherArray a (Array b) = Array $ V.snoc b a + gatherArray (Array a) b = Array $ V.cons b a + gatherArray a b = Array $ V.fromList [b, a] +insertConcat :: JS.Key -> Value -> Object -> Object +insertConcat key val = JS.insertWith prependJSON key (toJSON [val]) + where + prependJSON (Array a) (Array b) = Array $ a V.++ b + 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] diff --git a/src-lib/Hearth/TopSites.hs b/src-lib/Hearth/TopSites.hs index e69ed33..389ebbe 100644 --- a/src-lib/Hearth/TopSites.hs +++ b/src-lib/Hearth/TopSites.hs @@ -8,6 +8,7 @@ import Data.List (sortOn) import Data.Time.LocalTime (ZonedTime) type Link = (String, URI, ZonedTime) +link :: (a, b, c) -> b link (_, ret, _) = ret -- | Takes a reverse-chronologically-sorted list of labled links & hueristically -- reorders them by weighted-frequency. diff --git a/tpl/index.html b/tpl/index.html index 14bd94d..85aea37 100644 --- a/tpl/index.html +++ b/tpl/index.html @@ -2,7 +2,7 @@ - {{ _["Homepage"] }} + 🏠️{{ _["Homepage"] }}
@@ -12,9 +12,15 @@

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

+ {% if D.readingList %}
+

📚️{{ _["Reading List"] }}

+ +
{% endif %} -- 2.30.2