Tissevert/hablo
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Implement customizable texts

Browse source
This commit is contained in:
Tissevert 2019-02-17 19:52:28 +01:00
parent 00c3c602b9
commit 339a1e0d20
9 changed files with 176 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
hablo.cabal
View file

@ -18,6 +18,7 @@ extra-source-files: CHANGELOG.md
build-type: Simple
data-dir: share
data-files: js/*.js
defaultWording.conf
executable hablo
main-is: Main.hs
@ -27,6 +28,7 @@ executable hablo
, Blog
, Blog.Path
, Blog.Skin
, Blog.Wording
, Dom
, Files
, HTML
@ -45,6 +47,7 @@ executable hablo
, mtl
, optparse-applicative
, parsec
, template
, text
, time
, unix

7
share/defaultWording.conf Normal file
View file

@ -0,0 +1,7 @@
allLink = See all
allPage = All articles
allTaggedPage = All articles tagged ${tag}
latestLink = See only latest
latestPage = Latest articles
latestTaggedPage = Latest articles tagged ${tag}
tagsList = Tags

9
share/js/domRenderer.js
View file

@ -64,7 +64,12 @@ function DomRenderer(modules) {
}
function pageTitle(tag, all) {
return (all ? 'All' : 'Latest') + ' articles' + (tag != undefined ? ' tagged ' + tag : '');
if(tag != undefined) {
var template = blog.wording[all ? 'allTaggedPage' : 'latestTaggedPage'];
return template.replace(/([^$]|^)\$(?:{tag}|tag([^a-zA-Z]|$))/, '$1' + tag + '$2');
} else {
return blog.wording[all ? 'allPage' : 'latestPage'];
}
}
function otherUrl(tag, all) {
@ -78,7 +83,7 @@ function DomRenderer(modules) {
modules.dom.make('h2', {innerText: pageTitle(tag, all)}),
modules.dom.make('a', {
class: 'navigation',
innerText: all ? 'See only latest' : 'See all',
innerText: all ? blog.wording.latestLink : blog.wording.allLink,
href: otherUrl(tag, all)
}),
modules.dom.make('div', {class: 'articles'}, articlePreviews.filter(modules.fun.defined))

2
src/Arguments.hs
View file

@ -25,6 +25,7 @@ data Arguments = BlogConfig {
, pagesPath :: Maybe FilePath
, previewArticlesCount :: Int
, previewLinesCount :: Int
, wording :: Maybe FilePath
}
| Version
@ -70,6 +71,7 @@ blogConfig = BlogConfig
<> long "preview-lines"
<> help "number of lines to display in articles preview"
)
<*> option filePath 'w' "wording" "WORDING" "path to the file containing the wording to use"
version :: Parser Arguments
version = flag' Version (

26
src/ArticlesList.hs
View file

@ -1,12 +1,19 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module ArticlesList (
ArticlesList(..)
, otherLink
, otherUrl
, pageTitle
) where
import Article (Article)
import Blog (Blog(..), Wording(..), get)
import Control.Monad.Reader (MonadReader)
import Data.Text (Text, pack)
import Data.Text.Lazy (toStrict)
import Data.Text.Template (render)
import Pretty ((.$))
import System.FilePath.Posix ((</>))
data ArticlesList = ArticlesList {
@ -23,12 +30,11 @@ otherUrl (ArticlesList {full, tagged}) =
where
url = maybe "/" ("/" </>)
otherLink :: ArticlesList -> String
otherLink (ArticlesList {full}) =
if full
then "See only latest"
else "See all"
pageTitle :: ArticlesList -> String
pageTitle (ArticlesList {full, tagged}) =
(if full then "All" else "Latest") ++ " articles" ++ maybe "" (" tagged " ++) tagged
pageTitle :: (MonadReader Blog m) => ArticlesList -> m Text
pageTitle (ArticlesList {full, tagged}) = do
template <- Blog.get $wording.$(if full then allTaggedPage else latestTaggedPage)
untagged <- Blog.get $wording.$(if full then allPage else latestPage)
return $ maybe untagged (toStrict . render template . tag) tagged
where
tag :: String -> Text -> Text
tag t = \"tag" -> pack t

13
src/Blog.hs
View file

@ -4,6 +4,7 @@ module Blog (
Blog(..)
, Path(..)
, Skin(..)
, Wording(..)
, build
, get
) where
@ -16,11 +17,13 @@ import Blog.Path (Path(..))
import qualified Blog.Path as Path (build)
import Blog.Skin (Skin(..))
import qualified Blog.Skin as Skin (build)
import Blog.Wording (Wording(..))
import qualified Blog.Wording as Wording (build)
import Control.Monad ((>=>), filterM, forM)
import Control.Monad.Reader (MonadReader, ask)
import Data.Either (rights)
import Data.Map (Map)
import qualified Data.Map as Map (fromList, member)
import Data.Map (Map, (!?))
import qualified Data.Map as Map (fromList)
import Data.Set (Set)
import qualified Data.Set as Set (empty, null, singleton, union)
import qualified Files (find)
@ -35,6 +38,7 @@ data Blog = Blog {
, path :: Path
, skin :: Skin
, tags :: Map String (Set String)
, wording :: Wording
}
get :: MonadReader Blog m => (Blog -> a) -> m a
@ -58,17 +62,18 @@ tagged collection path = do
fileExists <- doesFileExist link
return $ if fileExists
then let articleKey = Article.getKey link in
if Map.member articleKey collection then Set.singleton articleKey else Set.empty
maybe Set.empty (\_ -> Set.singleton articleKey) (collection !? articleKey)
else Set.empty
return (takeFileName path, foldl Set.union Set.empty keys)
build :: Arguments -> IO Blog
build arguments = withCurrentDirectory (root path) $ do
skin <- Skin.build name arguments
wording <- Wording.build arguments
articles <- findArticles $ articlesPath path
tags <- Map.fromList . filter (not . Set.null . snd)
<$> (Files.find (articlesPath path </> "tags") >>= mapM (articles `tagged`))
return $ Blog {articles, name, path, skin, tags}
return $ Blog {articles, name, path, skin, tags, wording}
where
path = Path.build arguments
name = maybe (takeFileName . dropTrailingPathSeparator $ root path) id

89
src/Blog/Wording.hs Normal file
View file

@ -0,0 +1,89 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Blog.Wording (
Wording(..)
, build
) where
import Arguments (Arguments(..))
import Control.Monad (foldM)
import Data.List (intercalate)
import Data.Map (Map, (!))
import qualified Data.Map as Map (empty, fromList, map, union)
import Data.Text (Text)
import qualified Data.Text as Text (pack, unpack)
import Data.Text.Template (Template, renderA, templateSafe)
import Paths_hablo (getDataFileName)
import Text.ParserCombinators.Parsec (
Parser
, (<|>)
, char, choice, endBy, many, many1, noneOf, parse, string, try
)
import System.Exit (die)
data Wording = Wording {
allLink :: Text
, allPage :: Text
, allTaggedPage :: Template
, latestLink :: Text
, latestPage :: Text
, latestTaggedPage :: Template
, tagsList :: Text
}
keys :: [Parser String]
keys = try . string <$> [
"allLink"
, "allPage"
, "allTaggedPage"
, "latestLink"
, "latestPage"
, "latestTaggedPage"
, "tagsList"
]
addWording :: Map String Text -> FilePath -> IO (Map String Text)
addWording currentWording wordingFile = do
parsed <- parse wordingP wordingFile <$> readFile wordingFile
case parsed of
Left errorMessage -> die $ show errorMessage
Right newWording -> return $ Map.union currentWording newWording
wordingP :: Parser (Map String Text)
wordingP = Map.map Text.pack . Map.fromList <$> (many eol *> line `endBy` (many1 eol))
where
line = (,) <$> (choice keys <* equal) <*> many (noneOf "\r\n")
equal = many (char ' ') *> char '=' *> many (char ' ')
eol = try (string "\r\n") <|> string "\r" <|> string "\n"
checkTemplateWith :: [Text] -> String -> Map String Text -> IO Template
checkTemplateWith variables key wording =
let templateText = wording ! key in
let testEnvironment = flip lookup [(s, "") | s <- variables] in
case templateSafe templateText of
Left (row, col) -> die $ syntaxError (show row) (show col)
Right template ->
maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
where
availableVariables =
" (available variables: " ++ intercalate ", " (Text.unpack <$> variables) ++ ")"
syntaxError row col =
"Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
badTemplate = "Invalid template for variable " ++ key ++ availableVariables
build :: Arguments -> IO Wording
build arguments = do
defaultWording <- getDataFileName "defaultWording.conf"
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
wording <- foldM addWording Map.empty wordingFiles
allTaggedPage <- checkTemplateWith ["tag"] "allTaggedPage" wording
latestTaggedPage <- checkTemplateWith ["tag"] "latestTaggedPage" wording
return Wording {
allLink = wording ! "allLink"
, allPage = wording ! "allPage"
, allTaggedPage
, latestLink = wording ! "latestLink"
, latestPage = wording ! "latestPage"
, latestTaggedPage
, tagsList = wording ! "tagsList"
}

33
src/Dom.hs
View file

@ -6,13 +6,13 @@ module Dom (
import Article (Article(..))
import qualified Article (preview)
import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle)
import Blog (Blog(..), Path(..), Skin(..))
import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
import Blog (Blog(..), Path(..), Skin(..), Wording(..))
import qualified Blog (get)
import Control.Monad.Reader (ReaderT)
import qualified Data.Map as Map (keys)
import Data.Monoid ((<>))
import Data.Text (pack, empty)
import Data.Text (Text, pack, empty)
import Lucid
import Lucid.Base (makeAttribute)
import Prelude hiding (head)
@ -27,23 +27,24 @@ class Page a where
instance Page Article where
card (Article {title}) =
("A new article on " <>) <$> Blog.get name
>>= makeCard title
makeCard title =<< (Blog.get $name.$("A new article on " <>).$pack)
content = article True
instance Page ArticlesList where
card al = do
blogName <- Blog.get name
makeCard (maybe blogName ((blogName ++ " - ") ++) $ tagged al) (pageTitle al)
makeCard (maybe blogName ((blogName ++ " - ") ++) $ tagged al) =<< pageTitle al
content al@(ArticlesList {featured}) = do
content al@(ArticlesList {featured, full}) = do
preview <- Article.preview <$> (Blog.get $skin.$previewLinesCount)
h2_ . toHtml . pack $ pageTitle al
navigationA [href_ . pack $ otherUrl al] . toHtml . pack $ otherLink al
h2_ . toHtml =<< pageTitle al
navigationA [href_ . pack $ otherUrl al] . toHtml =<< otherLink
div_ [class_ "articles"] (
mapM_ (article False . preview) featured
)
where
otherLink = Blog.get $wording.$(if full then latestLink else allLink)
article :: Bool -> Article -> HtmlGenerator ()
article raw (Article {key, body, title}) = do
@ -57,14 +58,14 @@ article raw (Article {key, body, title}) = do
where
(aElem, extension) = if raw then (a_, "md") else (navigationA, "html")
makeCard :: String -> String -> HtmlGenerator ()
makeCard :: String -> Text -> HtmlGenerator ()
makeCard title description = do
og "title" title
og "title" $ pack title
og "description" description
og "image" =<< (Blog.get $skin.$cardImage)
og "site_name" =<< Blog.get name
og "image" =<< (Blog.get $skin.$cardImage.$pack)
og "site_name" =<< (Blog.get $name.$pack)
where
og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ $ pack value]
og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ value]
navigationA :: Term arg result => arg -> result
navigationA = "a" `termWith` [class_ "navigation"]
@ -97,9 +98,9 @@ page aPage =
(Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
)
body_ (do
(Blog.get $skin.$banner) >>= maybe defaultBanner toHtmlRaw
maybe defaultBanner toHtmlRaw =<< (Blog.get $skin.$banner)
div_ [id_ "navigator"] (do
h2_ "Tags"
h2_ =<< (Blog.get $wording.$tagsList.$toHtml)
ul_ . mapM_ tag . Map.keys =<< Blog.get tags
)
div_ [id_ "contents"] $ content aPage

27
src/JSON.hs
View file

@ -7,13 +7,15 @@ module JSON (
import Article (Article)
import qualified Article (Article(..))
import Blog (Blog)
import qualified Blog (Blog(..), Path(..), Skin(..))
import qualified Blog (Blog(..), Path(..), Skin(..), Wording(..))
import Control.Monad.Reader (ReaderT, ask)
import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
import Data.ByteString.Lazy (ByteString)
import Data.Map (Map, mapWithKey)
import qualified Data.Map as Map (filter, keys)
import qualified Data.Set as Set (elems, member)
import Data.Text (Text)
import Data.Text.Template (showTemplate)
import GHC.Generics
data ArticleExport = ArticleExport {
@ -43,11 +45,25 @@ data SkinExport = SkinExport {
instance ToJSON SkinExport where
toEncoding = genericToEncoding defaultOptions
data WordingExport = WordingExport {
allLink :: Text
, allPage :: Text
, allTaggedPage :: Text
, latestLink :: Text
, latestPage :: Text
, latestTaggedPage :: Text
, tagsList :: Text
} deriving (Generic)
instance ToJSON WordingExport where
toEncoding = genericToEncoding defaultOptions
data BlogDB = BlogDB {
articles :: Map String ArticleExport
, path :: PathExport
, skin :: SkinExport
, tags :: Map String [String]
, wording :: WordingExport
} deriving (Generic)
instance ToJSON BlogDB where
@ -76,4 +92,13 @@ exportBlog = do
, previewLinesCount = Blog.previewLinesCount $ Blog.skin blog
}
, tags = Set.elems <$> Blog.tags blog
, wording = WordingExport {
allLink = Blog.allLink $ Blog.wording blog
, allPage = Blog.allPage $ Blog.wording blog
, allTaggedPage = showTemplate . Blog.allTaggedPage $ Blog.wording blog
, latestLink = Blog.latestLink $ Blog.wording blog
, latestPage = Blog.latestPage $ Blog.wording blog
, latestTaggedPage = showTemplate . Blog.latestTaggedPage $ Blog.wording blog
, tagsList = Blog.tagsList $ Blog.wording blog
}
}