Skip to content

Commit dd603e3

Browse files
unorskunorsk
committed
Lucid
1 parent a865089 commit dd603e3

File tree

3 files changed

+54
-64
lines changed

3 files changed

+54
-64
lines changed

‎blogroll.cabal‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,8 @@ library
3434
containers,
3535
base64-bytestring,
3636
network-uri,
37-
async
37+
async,
38+
lucid2
3839

3940
hs-source-dirs: src/
4041
default-language: GHC2024
@@ -49,6 +50,7 @@ executable blogroll
4950
text,
5051
containers,
5152
base64-bytestring,
53+
lucid2,
5254
blogroll
5355

5456
hs-source-dirs: app

‎src/Blogroll/Fetch.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ import Data.Text qualified as T
1414
import Data.Text.Encoding qualified as TE
1515
import Data.Time (diffUTCTime, getCurrentTime)
1616
import Network.HTTP.Simple (getResponseBody, httpLBS, parseRequest, setRequestHeaders)
17-
import Network.URI (URI (..))
17+
import Network.URI (URI (..), uriRegName)
1818

1919
fetchAllFavicons :: [URI] -> IO (Map.Map Text Text)
2020
fetchAllFavicons urls = do
@@ -58,7 +58,11 @@ fetchFeed url = do
5858
Right body -> return $ Right body
5959

6060
extractDomain :: URI -> Text
61-
extractDomain url = T.drop (T.length (T.pack $ uriScheme url) + 2) (T.pack $ show url)
61+
extractDomain url = do
62+
let domain1 = uriAuthority url
63+
in case domain1 of
64+
Just domain -> T.pack $ uriRegName domain
65+
Nothing -> T.pack "" -- TODO yet again, I'll fix this later
6266

6367
fetchFavicon :: Text -> IO (Maybe Text)
6468
fetchFavicon domain = do

‎src/Blogroll/Html.hs‎

Lines changed: 45 additions & 61 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,9 @@ import Data.Text (Text)
1616
import Data.Text qualified as T
1717
import Data.Text.Encoding qualified as TE
1818
import Data.Text.IO qualified as TIO
19+
import Data.Text.Lazy qualified as TL
1920
import Data.Time (defaultTimeLocale, formatTime)
21+
import Lucid
2022

2123
generateDomainCssClass :: Text -> Text
2224
generateDomainCssClass domain =
@@ -84,39 +86,41 @@ renderAll blogroll = do
8486
putStrLn "Generated index.html (25 recent) and all.html"
8587

8688
renderHtml :: [FeedEntry] -> Text -> Text -> Maybe Text -> Text
87-
renderHtml entries title faviconCss maybeFontBase64 =
88-
let entriesHtml = T.concat $ map renderEntry entries
89-
fontFace = case maybeFontBase64 of
90-
Just fontBase64 ->
91-
"""@font-face {
92-
font-family: 'IBM Plex Sans';
93-
src: url(data:font/woff2;base64,"""
94-
<> fontBase64
95-
<> """) format('woff2');
96-
font-weight: 400;
97-
}"""
98-
Nothing ->
99-
"""@font-face {
100-
font-family: 'IBM Plex Sans';
101-
src: url('IBMPlexSans-Regular.woff2') format('woff2');
102-
font-weight: 400;
103-
}"""
104-
in """
105-
<!DOCTYPE html>
106-
<html>
107-
<head>
108-
<meta name="viewport" content="width=device-width, initial-scale=1.0">
109-
<title>RSS Reader</title>
110-
<style>
111-
"""
112-
<> fontFace
113-
<> """
89+
renderHtml entries pageTitle faviconCss maybeFontBase64 =
90+
TL.toStrict $ renderText $ doctype_ <> html_ (do
91+
head_ (do
92+
meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
93+
title_ "RSS Reader"
94+
style_ [] (toHtmlRaw $ generateStyles faviconCss maybeFontBase64))
95+
body_ (do
96+
h1_ (toHtml pageTitle)
97+
ul_ (do
98+
mapM_ renderEntry entries
99+
li_ (a_ [href_ "all.html"] "See all"))))
100+
where
101+
generateStyles :: Text -> Maybe Text -> Text
102+
generateStyles css maybeFontB64 =
103+
let fontFace = case maybeFontB64 of
104+
Just fontBase64 ->
105+
"""@font-face {
106+
font-family: 'IBM Plex Sans';
107+
src: url(data:font/woff2;base64,"""
108+
<> fontBase64
109+
<> """) format('woff2');
110+
font-weight: 400;
111+
}"""
112+
Nothing ->
113+
"""@font-face {
114+
font-family: 'IBM Plex Sans';
115+
src: url('IBMPlexSans-Regular.woff2') format('woff2');
116+
font-weight: 400;
117+
}"""
118+
in fontFace
119+
<> """
114120
body {
115121
font-family: 'IBM Plex Sans', -apple-system, sans-serif;
116122
max-width: 800px;
117123
margin: 0 auto;
118-
/* padding-left: 0.5em; */
119-
/* padding-right: 0.5em; */
120124
color: #333;
121125
display: flex;
122126
flex-flow: column;
@@ -154,36 +158,16 @@ renderHtml entries title faviconCss maybeFontBase64 =
154158
padding-left: 0.5em;
155159
}
156160
"""
157-
<> faviconCss
158-
<> """
159-
</style>
160-
</head>
161-
<body>
162-
<h1>"""
163-
<> title
164-
<> """</h1>
165-
<ul>
166-
"""
167-
<> entriesHtml
168-
<> """
169-
<li><a href=\"all.html\">See all</a></li>
170-
</ul>
171-
</body>
172-
</html>
173-
"""
174-
where
161+
<> css
162+
163+
renderEntry :: FeedEntry -> Html ()
175164
renderEntry entry =
176-
T.concat
177-
[ "<li><div><a href=\"",
178-
T.pack $ show $ entryLink entry,
179-
"\" class=\"",
180-
generateDomainCssClass (extractDomain entry.entrySiteUrl),
181-
"\">",
182-
entryTitle entry,
183-
"</a><span class=\"source\">(",
184-
extractDomain entry.entrySiteUrl,
185-
")</span></div>",
186-
"<div class=\"date\">",
187-
T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" entry.entryDate,
188-
"</div></li>"
189-
]
165+
li_ (do
166+
div_ (do
167+
a_
168+
[ href_ (T.pack $ show $ entryLink entry),
169+
class_ (generateDomainCssClass (extractDomain entry.entrySiteUrl))
170+
]
171+
(toHtml $ entryTitle entry)
172+
span_ [class_ "source"] (toHtml $ "(" <> extractDomain entry.entrySiteUrl <> ")"))
173+
div_ [class_ "date"] (toHtml $ T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" entry.entryDate))

0 commit comments

Comments
 (0)