mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore(tazblog): Remove i18n features

Browse source 
The blog has been English only for a few years. Old entries that
survived the migration to DNS will still be accessible.
This commit is contained in:
Vincent Ambo 2019-08-25 22:53:38 +01:00
parent 094aafecdd
commit 561ed1fbbb
7 changed files with 77 additions and 164 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
services/tazblog/blog/Main.hs
View file

@ -2,7 +2,6 @@
module Main where module Main where
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Locales (version)
import Server (runBlog) import Server (runBlog)
import System.Environment (getEnv) import System.Environment (getEnv)
@ -20,6 +19,6 @@ readOpts =
main :: IO () main :: IO ()
main = do main = do
putStrLn ("TazBlog " ++ version ++ " in Haskell starting")
opts <- readOpts opts <- readOpts
putStrLn ("tazblog starting on port " ++ (show $ blogPort opts))
runBlog (blogPort opts) (resourceDir opts) runBlog (blogPort opts) (resourceDir opts)

62
services/tazblog/src/Blog.hs
View file

@ -12,15 +12,22 @@
module Blog where module Blog where
import BlogStore import BlogStore
import Data.Text (Text, empty, pack) import Data.Text (Text, pack)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Lazy (fromStrict) import Data.Text.Lazy (fromStrict)
import Data.Time import Data.Time
import Locales
import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html (preEscapedToHtml)
import Text.Hamlet import Text.Hamlet
import Text.Markdown import Text.Markdown
blogTitle :: Text = "tazjin's blog"
repoURL :: Text = "https://bitbucket.org/tazjin/tazblog-haskell"
mailTo :: Text = "mailto:mail@tazj.in"
twitter :: Text = "https://twitter.com/tazjin"
replace :: Eq a => a -> a -> [a] -> [a] replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z) replace x y = map (\z -> if z == x then y else z)
@ -28,27 +35,25 @@ replace x y = map (\z -> if z == x then y else z)
markdownCutoff :: Day markdownCutoff :: Day
markdownCutoff = fromGregorian 2013 04 28 markdownCutoff = fromGregorian 2013 04 28
blogTemplate :: BlogLang -> Text -> Html -> Html blogTemplate :: Text -> Html -> Html
blogTemplate lang t_append body = blogTemplate t_append body =
[shamlet| [shamlet|
$doctype 5 $doctype 5
<head> <head>
<meta charset="utf-8"> <meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1"> <meta name="viewport" content="width=device-width, initial-scale=1">
<meta name="description" content=#{blogTitle lang t_append}> <meta name="description" content=#{blogTitle}#{t_append}>
<link rel="stylesheet" type="text/css" href="/static/blog.css" media="all"> <link rel="stylesheet" type="text/css" href="/static/blog.css" media="all">
<link rel="alternate" type="application/rss+xml" title="RSS-Feed" href=#{rssUrl}> <link rel="alternate" type="application/rss+xml" title="RSS-Feed" href="/rss.xml">
<title>#{blogTitle lang t_append} <title>#{blogTitle}#{t_append}
<body> <body>
<header> <header>
<h1> <h1>
<a href="/" .unstyled-link>#{blogTitle lang empty} <a href="/" .unstyled-link>#{blogTitle}
<hr> <hr>
^{body} ^{body}
^{showFooter} ^{showFooter}
|] |]
where
rssUrl = T.concat ["/", show' lang, "/rss.xml"]
showFooter :: Html showFooter :: Html
showFooter = showFooter =
@ -56,7 +61,7 @@ showFooter =
<footer> <footer>
<p .footer>Served without any dynamic languages. <p .footer>Served without any dynamic languages.
<p .footer> <p .footer>
<a href=#{repoURL} .uncoloured-link>Version #{version} <a href=#{repoURL} .uncoloured-link>
| |
<a href=#{twitter} .uncoloured-link>Twitter <a href=#{twitter} .uncoloured-link>Twitter
| |
@ -90,28 +95,26 @@ $maybe links <- pageLinks
^{links} ^{links}
|] |]
where where
linkElems Entry {..} = concat $ ["/", show lang, "/", show entryId] linkElems Entry {..} = concat $ ["/", show entryId]
showLinks :: Maybe Int -> BlogLang -> Html showLinks :: Maybe Int -> Html
showLinks (Just i) lang = showLinks (Just i) =
[shamlet| [shamlet|
$if ((>) i 1) $if ((>) i 1)
<div .navigation> <div .navigation>
<a href=#{nLink $ succ i} .uncoloured-link>#{backText lang} <a href=#{nLink $ succ i} .uncoloured-link>Earlier
| |
<a href=#{nLink $ pred i} .uncoloured-link>#{nextText lang} <a href=#{nLink $ pred i} .uncoloured-link>Later
$elseif ((<=) i 1) $elseif ((<=) i 1)
^{showLinks Nothing lang} ^{showLinks Nothing}
|] |]
where where
nLink page = T.concat ["/", show' lang, "/?page=", show' page] nLink page = T.concat ["/?page=", show' page]
showLinks Nothing lang = showLinks Nothing =
[shamlet| [shamlet|
<div .navigation> <div .navigation>
<a href=#{nLink} .uncoloured-link>#{backText lang} <a href="/?page=2" .uncoloured-link>Earlier
|] |]
where
nLink = T.concat ["/", show' lang, "/?page=2"]
renderEntry :: Entry -> Html renderEntry :: Entry -> Html
renderEntry e@Entry {..} = renderEntry e@Entry {..} =
@ -128,18 +131,11 @@ renderEntry e@Entry {..} =
<hr> <hr>
|] |]
showError :: BlogError -> BlogLang -> Html showError :: Text -> Text -> Html
showError NotFound l = showError title err =
blogTemplate l (T.append ": " $ notFoundTitle l) blogTemplate (": " <> title)
$ [shamlet| $ [shamlet|
<p>:( <p>:(
<p>#{notFoundText l} <p>#{err}
<hr>
|]
showError UnknownError l =
blogTemplate l ""
$ [shamlet|
<p>:(
<p>#{unknownErrorText l}
<hr> <hr>
|] |]

3
services/tazblog/src/BlogStore.hs
View file

@ -40,7 +40,6 @@ import Data.List (sortBy)
import Data.Text as T (Text, concat, pack) import Data.Text as T (Text, concat, pack)
import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Time (Day) import Data.Time (Day)
import Locales (BlogLang (..))
import Network.DNS (DNSError, lookupTXT) import Network.DNS (DNSError, lookupTXT)
import qualified Network.DNS.Resolver as R import qualified Network.DNS.Resolver as R
@ -54,7 +53,6 @@ instance Show EntryId where
data Entry data Entry
= Entry = Entry
{ entryId :: EntryId, { entryId :: EntryId,
lang :: BlogLang,
author :: Text, author :: Text,
title :: Text, title :: Text,
text :: Text, text :: Text,
@ -166,7 +164,6 @@ entryFromDNS cache eid = do
$ either Left $ either Left
( \text -> Right $ Entry ( \text -> Right $ Entry
{ entryId = eid, { entryId = eid,
lang = EN,
author = "tazjin", author = "tazjin",
title = t, title = t,
text = text, text = text,

71
services/tazblog/src/Locales.hs
View file

@ -1,71 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Locales where
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Network.URI
data BlogLang = EN | DE
deriving (Eq, Ord)
instance Show BlogLang where
show DE = "de"
show EN = "en"
data BlogError = NotFound | UnknownError
version = "6.0.0"
blogTitle :: BlogLang -> Text -> Text
blogTitle DE s = T.concat ["Tazjins blog", s]
blogTitle EN s = T.concat ["Tazjin's blog", s]
showLangText :: BlogLang -> Text
showLangText EN = "en"
showLangText DE = "de"
backText :: BlogLang -> Text
backText DE = "Früher"
backText EN = "Earlier"
nextText :: BlogLang -> Text
nextText DE = "Später"
nextText EN = "Later"
readMore :: BlogLang -> Text
readMore DE = "[Weiterlesen]"
readMore EN = "[Read more]"
-- RSS Strings
rssTitle :: BlogLang -> String
rssTitle DE = "Tazjins Blog"
rssTitle EN = "Tazjin's Blog"
rssDesc :: BlogLang -> String
rssDesc DE = "Feed zu Tazjins Blog"
rssDesc EN = "Feed for Tazjin's Blog"
rssLink :: BlogLang -> URI
rssLink l = fromMaybe nullURI $ parseURI ("http://tazj.in/" ++ show l)
-- errors
notFoundTitle :: BlogLang -> Text
notFoundTitle DE = "Nicht gefunden"
notFoundTitle EN = "Not found"
notFoundText :: BlogLang -> Text
notFoundText DE = "Das gewünschte Objekt wurde leider nicht gefunden."
notFoundText EN = "The requested object could not be found."
unknownErrorText :: BlogLang -> Text
unknownErrorText DE = "Ein unbekannter Fehler ist aufgetreten."
unknownErrorText EN = "An unknown error has occured."
-- static information
repoURL :: Text = "https://bitbucket.org/tazjin/tazblog-haskell"
mailTo :: Text = "mailto:tazjin+blog@gmail.com"
twitter :: Text = "https://twitter.com/tazjin"

37
services/tazblog/src/RSS.hs
View file

@ -7,42 +7,43 @@ where
import BlogStore import BlogStore
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Maybe (fromMaybe) import Data.Maybe (fromJust)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time (UTCTime (..), getCurrentTime, secondsToDiffTime) import Data.Time (UTCTime (..), getCurrentTime, secondsToDiffTime)
import Locales import Network.URI (URI, parseURI)
import Network.URI
import Text.RSS import Text.RSS
createChannel :: BlogLang -> UTCTime -> [ChannelElem] createChannel :: UTCTime -> [ChannelElem]
createChannel l now = createChannel now =
[ Language $ show l, [ Language "en",
Copyright "Vincent Ambo", Copyright "Vincent Ambo",
WebMaster "mail@tazj.in", WebMaster "mail@tazj.in",
ChannelPubDate now ChannelPubDate now
] ]
createRSS :: BlogLang -> UTCTime -> [Item] -> RSS createRSS :: UTCTime -> [Item] -> RSS
createRSS l t = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) createRSS t =
let link = fromJust $ parseURI "https://tazj.in"
in RSS "tazjin's blog" link "tazjin's blog feed" (createChannel t)
createItem :: Entry -> Item createItem :: Entry -> Item
createItem Entry {..} = createItem Entry {..} =
[ Title $ T.unpack title, [ Title "tazjin's blog",
Link $ makeLink lang entryId, Link $ entryLink entryId,
Description $ T.unpack text, Description $ T.unpack text,
PubDate $ UTCTime edate $ secondsToDiffTime 0 PubDate $ UTCTime edate $ secondsToDiffTime 0
] ]
makeLink :: BlogLang -> EntryId -> URI entryLink :: EntryId -> URI
makeLink l i = entryLink i =
let url = "http://tazj.in/" ++ show l ++ "/" ++ show i let url = "http://tazj.in/" ++ "/" ++ show i
in fromMaybe nullURI $ parseURI url in fromJust $ parseURI url
createItems :: [Entry] -> [Item] createItems :: [Entry] -> [Item]
createItems = map createItem createItems = map createItem
createFeed :: BlogLang -> [Entry] -> IO RSS createFeed :: [Entry] -> IO RSS
createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e) createFeed e = getCurrentTime >>= (\t -> return $ createRSS t $ createItems e)
renderFeed :: BlogLang -> [Entry] -> IO String renderFeed :: [Entry] -> IO String
renderFeed l e = liftM (showXML . rssToXML) (createFeed l e) renderFeed e = liftM (showXML . rssToXML) (createFeed e)

63
services/tazblog/src/Server.hs
View file

@ -10,20 +10,11 @@ import BlogStore
import Control.Applicative (optional) import Control.Applicative (optional)
import Control.Monad (msum) import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import Data.Maybe (maybe) import Data.Maybe (maybe)
import qualified Data.Text as T import qualified Data.Text as T
import Happstack.Server hiding (Session) import Happstack.Server hiding (Session)
import Locales
import RSS import RSS
instance FromReqURI BlogLang where
fromReqURI sub =
case map toLower sub of
"de" -> Just DE
"en" -> Just EN
_ -> Nothing
pageSize :: Int pageSize :: Int
pageSize = 3 pageSize = 3
@ -33,26 +24,27 @@ tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
runBlog :: Int -> String -> IO () runBlog :: Int -> String -> IO ()
runBlog port respath = do runBlog port respath = do
withCache "blog.tazj.in." $ \cache -> withCache "blog.tazj.in." $ \cache ->
simpleHTTP nullConf {port = port} $ tazBlog cache respath simpleHTTP nullConf {port = port} $ tazblog cache respath
tazBlog :: BlogCache -> String -> ServerPart Response tazblog :: BlogCache -> String -> ServerPart Response
tazBlog cache resDir = do tazblog cache resDir = do
msum msum
[ path $ \(lang :: BlogLang) -> blogHandler cache lang, [ -- legacy language-specific routes
dir "de" $ blogHandler cache,
dir "en" $ blogHandler cache,
dir "static" $ staticHandler resDir, dir "static" $ staticHandler resDir,
blogHandler cache EN, blogHandler cache,
staticHandler resDir, staticHandler resDir,
notFound $ toResponse $ showError NotFound DE notFound $ toResponse $ showError "Not found" "Page not found"
] ]
blogHandler :: BlogCache -> BlogLang -> ServerPart Response blogHandler :: BlogCache -> ServerPart Response
blogHandler cache lang = blogHandler cache =
msum msum
[ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId, [ path $ \(eId :: Integer) -> showEntry cache $ EntryId eId,
nullDir >> showIndex cache lang, nullDir >> showIndex cache,
dir "rss" $ nullDir >> showRSS cache lang, dir "rss" $ nullDir >> showRSS cache,
dir "rss.xml" $ nullDir >> showRSS cache lang, dir "rss.xml" $ nullDir >> showRSS cache
notFound $ toResponse $ showError NotFound lang
] ]
staticHandler :: String -> ServerPart Response staticHandler :: String -> ServerPart Response
@ -61,31 +53,30 @@ staticHandler resDir = do
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT" setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
serveDirectory DisableBrowsing [] resDir serveDirectory DisableBrowsing [] resDir
showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response showEntry :: BlogCache -> EntryId -> ServerPart Response
showEntry cache lang eId = do showEntry cache eId = do
entry <- getEntry cache eId entry <- getEntry cache eId
tryEntry entry lang tryEntry entry
tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response tryEntry :: Maybe Entry -> ServerPart Response
tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang tryEntry Nothing = notFound $ toResponse $ showError "Not found" "Blog entry not found"
tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry tryEntry (Just entry) = ok $ toResponse $ blogTemplate eTitle $ renderEntry entry
where where
eTitle = T.append ": " (title entry) eTitle = T.append ": " (title entry)
eLang = lang entry
offset :: Maybe Int -> Int offset :: Maybe Int -> Int
offset = maybe 0 ((*) pageSize) offset = maybe 0 ((*) pageSize)
showIndex :: BlogCache -> BlogLang -> ServerPart Response showIndex :: BlogCache -> ServerPart Response
showIndex cache lang = do showIndex cache = do
(page :: Maybe Int) <- optional $ lookRead "page" (page :: Maybe Int) <- optional $ lookRead "page"
entries <- listEntries cache (offset page) pageSize entries <- listEntries cache (offset page) pageSize
ok $ toResponse $ blogTemplate lang "" ok $ toResponse $ blogTemplate ""
$ renderEntries entries (Just $ showLinks page lang) $ renderEntries entries (Just $ showLinks page)
showRSS :: BlogCache -> BlogLang -> ServerPart Response showRSS :: BlogCache -> ServerPart Response
showRSS cache lang = do showRSS cache = do
entries <- listEntries cache 0 4 entries <- listEntries cache 0 4
feed <- liftIO $ renderFeed lang entries feed <- liftIO $ renderFeed entries
setHeaderM "content-type" "text/xml" setHeaderM "content-type" "text/xml"
ok $ toResponse feed ok $ toResponse feed

2
services/tazblog/tazblog.cabal
View file

@ -12,7 +12,7 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -W ghc-options: -W
exposed-modules: Blog, BlogStore, Locales, Server, RSS exposed-modules: Blog, BlogStore, Server, RSS
build-depends: aeson, build-depends: aeson,
base, base,
bytestring, bytestring,