~alcinnz/Hearth

ref: 3871d4b028cb9d1cf35050a711ad6d6de8a3c4f5 Hearth/src-lib/Hearth.hs -rw-r--r-- 4.6 KiB
3871d4b0 — Adrian Cochrane Add reading-list support! 11 months ago
                                                                                
4e156709 Adrian Cochrane
3871d4b0 Adrian Cochrane
4e156709 Adrian Cochrane
3871d4b0 Adrian Cochrane
4e156709 Adrian Cochrane
ad72934e Adrian Cochrane
3871d4b0 Adrian Cochrane
ad72934e Adrian Cochrane
3871d4b0 Adrian Cochrane
4e156709 Adrian Cochrane
3871d4b0 Adrian Cochrane
4e156709 Adrian Cochrane
ad72934e Adrian Cochrane
4e156709 Adrian Cochrane
ad72934e Adrian Cochrane
4e156709 Adrian Cochrane
ad72934e Adrian Cochrane
4e156709 Adrian Cochrane
ad72934e Adrian Cochrane
4e156709 Adrian Cochrane
3871d4b0 Adrian Cochrane
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Hearth (renderPage, handleForm, markAsRead, utf8, Link) 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 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] -> 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
    Nothing -> Nothing
  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
    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
    | 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
    | "-" `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
------

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]