6 files changed, 109 insertions(+), 26 deletions(-)

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

@@ 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

@@ 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

@@ 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"
 }

@@ 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]

@@ 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.

@@ 2,7 2,7 @@
 <html>
 <head>
   <meta charset=utf-8 />
-  <title>{{ _["Homepage"] }}</title>
+  <title>🏠️{{ _["Homepage"] }}</title>
 </head>
 <body>
   <form method="POST">


@@ 12,9 12,15 @@
     <section>
       <h1><a href="history.html">⏳️{{ _["History"] }}</a></h1>
       <ul>{% for topsite in tops %}
-        <li><a href="{{ topsite.href }}">{{ topsite.label }}</a></li>
+        <li><a href="{{ topsite.href }}" title="{{ link.title }}">{{ topsite.label }}</a></li>
       {% endfor %}</ul>
     </section>
+    {% if D.readingList %}<section>
+      <h1><a href="toread.html">📚️{{ _["Reading List"] }}</a></h1>
+      <ul>{% for link in D.readingList|slice(0, 20) %}
+        <li><a href="/read/{{ link.href }}" title="{{ link.title }}">{{ link.label }}</a></li>
+      {% endfor %}</ul>
+    </section>{% endif %}
   </main>
 </body>
 </html>