diff --git a/hablo.cabal b/hablo.cabal index 71e2cdb..1289a7b 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -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 diff --git a/share/defaultWording.conf b/share/defaultWording.conf new file mode 100644 index 0000000..10384c2 --- /dev/null +++ b/share/defaultWording.conf @@ -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 diff --git a/share/js/domRenderer.js b/share/js/domRenderer.js index 0fb9452..c84cb8b 100644 --- a/share/js/domRenderer.js +++ b/share/js/domRenderer.js @@ -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)) diff --git a/src/Arguments.hs b/src/Arguments.hs index 6147b5d..f75bac2 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -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 ( diff --git a/src/ArticlesList.hs b/src/ArticlesList.hs index c7545a5..37c083b 100644 --- a/src/ArticlesList.hs +++ b/src/ArticlesList.hs @@ -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 diff --git a/src/Blog.hs b/src/Blog.hs index b17ebd0..27ef651 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -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 diff --git a/src/Blog/Wording.hs b/src/Blog/Wording.hs new file mode 100644 index 0000000..97ce80a --- /dev/null +++ b/src/Blog/Wording.hs @@ -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" + } diff --git a/src/Dom.hs b/src/Dom.hs index c39c229..b3333f6 100644 --- a/src/Dom.hs +++ b/src/Dom.hs @@ -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 diff --git a/src/JSON.hs b/src/JSON.hs index 1dbe427..326eadf 100644 --- a/src/JSON.hs +++ b/src/JSON.hs @@ -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 + } }