From 38846e1addc78cf7d7cc3eea2210d54d8ee31128 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 3 Feb 2019 22:56:21 +0100 Subject: [PATCH] Add a module to handle pages with articles list and generate HTML pages for articles too --- hablo.cabal | 1 + src/Article.hs | 12 ++++--- src/Blog.hs | 10 ++++-- src/Dom.hs | 63 ++++++++++++++++++------------------ src/HTML.hs | 86 ++++++++++++++++++++++++++++++++++---------------- src/Main.hs | 5 ++- 6 files changed, 107 insertions(+), 70 deletions(-) diff --git a/hablo.cabal b/hablo.cabal index eb9cac6..dce3ccb 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -20,6 +20,7 @@ executable hablo main-is: Main.hs other-modules: Arguments , Article + , ArticlesList , Blog , Dom , HTML diff --git a/src/Article.hs b/src/Article.hs index 40ef9a3..bc73301 100644 --- a/src/Article.hs +++ b/src/Article.hs @@ -6,16 +6,16 @@ module Article ( ) where import Control.Monad.State (evalState, modify, state) -import Data.Text (Text, pack) -import System.FilePath (()) +import System.FilePath (dropExtension) import System.Posix.Types (FileID) import System.Posix.Files (FileStatus, getFileStatus, fileID) data Article = Article { - urlPath :: Text + urlPath :: String , fileStatus :: FileStatus , title :: String , preview :: String + , fullContents :: String } getTitle :: [String] -> (String, [String]) @@ -38,14 +38,16 @@ parseBegining linesCount = evalState (do at :: Int -> FilePath -> IO (FileID, Article) at linesCount filePath = do fileStatus <- getFileStatus filePath - (title, preview) <- parseBegining linesCount <$> readFile filePath + fullContents <- readFile filePath + let (title, preview) = parseBegining linesCount fullContents return ( fileID fileStatus , Article { - urlPath = pack $ "/" filePath + urlPath = dropExtension filePath , fileStatus , title , preview + , fullContents } ) diff --git a/src/Blog.hs b/src/Blog.hs index 77d9db6..092ae69 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} module Blog ( Blog(..) + , build , get ) where @@ -9,6 +11,7 @@ import qualified Arguments (previewArticlesCount, previewLinesCount) import Article (Article) import qualified Article (at) import Control.Monad ((>=>), filterM, forM) +import Control.Monad.Reader (MonadReader, ask) import Data.Map (Map) import qualified Data.Map as Map (fromList, member) import Data.Set (Set) @@ -31,6 +34,9 @@ data Blog = Blog { , customHead :: Maybe String } +get :: MonadReader Blog m => (Blog -> a) -> m a +get = (<$> ask) + find :: FilePath -> IO [FilePath] find path = fmap (path ) <$> listDirectory path @@ -58,8 +64,8 @@ tagged collection path = do else return Set.empty return (takeFileName path, foldl Set.union Set.empty fileIDs) -get :: Arguments -> IO Blog -get arguments = withCurrentDirectory root $ do +build :: Arguments -> IO Blog +build arguments = withCurrentDirectory root $ do let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName arguments let previewLinesCount = Arguments.previewLinesCount arguments articles <- findArticles previewLinesCount articlesPath diff --git a/src/Dom.hs b/src/Dom.hs index c0e84a6..d20cbf9 100644 --- a/src/Dom.hs +++ b/src/Dom.hs @@ -1,33 +1,27 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Dom ( - Page(..) - , render + article + , articlesList + , page ) where import Article (Article(..)) +import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle) import Blog (Blog(..)) -import Control.Monad.Reader (MonadReader(..), ReaderT) +import qualified Blog (get) +import Control.Monad.Reader (ReaderT) import qualified Data.Map as Map (keys) import Data.Text (pack, empty) import Lucid -import System.FilePath.Posix (()) +import System.FilePath.Posix ((), (<.>)) type HtmlGenerator = HtmlT (ReaderT Blog IO) -data Page = Page { - category :: Maybe String - , full :: Bool - , articlesFeatured :: [Article] - } - -blog :: (Blog -> a) -> HtmlGenerator a -blog = (<$> ask) - previewArticle :: Article -> HtmlGenerator () previewArticle (Article {urlPath, title, preview}) = article_ (do - a_ [href_ urlPath] . h3_ $ toHtml title + a_ [href_ . pack $ "/" urlPath <.> "html"] . h3_ $ toHtml title pre_ $ toHtml preview ) @@ -36,42 +30,47 @@ tag tagName = li_ (a_ [href_ $ pack ("/" tagName)] $ toHtml tagName) banner :: HtmlGenerator () banner = do - maybe defaultBanner toHtmlRaw =<< blog customBanner + maybe defaultBanner toHtmlRaw =<< Blog.get customBanner defaultBanner :: HtmlGenerator () defaultBanner = do div_ [id_ "header"] ( a_ [href_ "/"] ( - h1_ . toHtml =<< blog name + h1_ . toHtml =<< Blog.get name ) ) -render :: Page -> HtmlGenerator () -render (Page {category, full, articlesFeatured}) = +article :: Article -> HtmlGenerator () +article (Article {fullContents, urlPath}) = + article_ (do + a_ [href_ . pack $ "/" urlPath <.> "md"] "Raw" + pre_ $ toHtml fullContents + ) + +articlesList :: ArticlesList -> HtmlGenerator () +articlesList al@(ArticlesList {featured}) = + div_ [id_ "contents"] (do + h2_ . toHtml $ pageTitle al + p_ . a_ [href_ $ otherUrl al] . toHtml $ otherLink al + div_ [class_ "articles"] (mapM_ previewArticle featured) + ) + +page :: HtmlGenerator () -> HtmlGenerator () +page contents = doctypehtml_ (do head_ (do meta_ [charset_ "utf-8"] - title_ . toHtml =<< blog name + title_ . toHtml =<< Blog.get name script_ [src_ "/UnitJS/async.js"] empty script_ [src_ "/UnitJS/dom.js"] empty - maybe (toHtml empty) toHtmlRaw =<< blog customHead + maybe (toHtml empty) toHtmlRaw =<< Blog.get customHead ) body_ (do banner div_ [id_ "navigator"] (do h2_ "Tags" - ul_ . mapM_ tag . Map.keys =<< blog tags - ) - div_ [id_ "contents"] (do - h2_ $ toHtml pageTitle - p_ $ if full - then a_ [href_ . pack $ url category] "See only latest" - else a_ [href_ . pack $ url category "all.html"] "See all" - div_ [class_ "articles"] (mapM_ previewArticle articlesFeatured) + ul_ . mapM_ tag . Map.keys =<< Blog.get tags ) + div_ [id_ "contents"] contents ) ) - where - pageTitle = - (if full then "All" else "Latest") ++ " articles" ++ maybe "" (" tagged " ++) category - url = maybe "/" ("/" ) diff --git a/src/HTML.hs b/src/HTML.hs index 2951e7a..a6c54fe 100644 --- a/src/HTML.hs +++ b/src/HTML.hs @@ -5,8 +5,10 @@ module HTML ( ) where import Article(Article(..)) +import ArticlesList (ArticlesList(..)) import Blog (Blog(..)) -import Control.Monad (forM_) +import qualified Blog (get) +import Control.Monad (forM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT) import Data.List (sortOn) @@ -14,40 +16,68 @@ import qualified Data.Map as Map (elems, filterWithKey, toList) import Data.Ord (Down(..)) import qualified Data.Set as Set (member) import qualified Data.Text.Lazy.IO as TextIO (writeFile) -import Dom (Page(..), render) +import qualified Dom (article, articlesList, page) import Lucid import System.Directory (createDirectoryIfMissing) -import System.FilePath.Posix (()) +import System.FilePath.Posix ((), (<.>)) import System.Posix.Files (modificationTime) -generateCollection :: (Maybe String, FilePath, [Article]) -> ReaderT Blog IO () -generateCollection (_, _, []) = return () -generateCollection (category, path, articlesFeatured) = do - blog <- ask - liftIO $ createDirectoryIfMissing False path - forM_ (pages $ previewArticlesCount blog) $ \(filePath, page) -> - renderTextT (render page) - >>= liftIO . TextIO.writeFile filePath +data Collection = Collection { + articlesFeatured :: [Article] + , basePath :: FilePath + , tag :: Maybe String + } + +collection :: Monad m => [Article] -> Maybe String -> ReaderT Blog m Collection +collection articlesFeatured tag = do + root <- Blog.get root + return $ Collection { + articlesFeatured = sortByDate articlesFeatured + , basePath = maybe root (root ) tag + , tag + } where - pages articlesCount = [ - (path "all.html", Page { - category - , full = True - , articlesFeatured - }) - , (path "index.html", Page { - category - , full = False - , articlesFeatured = take articlesCount articlesFeatured - }) - ] + sortByDate = sortOn (Down . modificationTime . fileStatus) + +articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)] +articlesLists (Collection {articlesFeatured, basePath, tag}) = do + limit <- take <$> Blog.get previewArticlesCount + return [ + (basePath "index.html", ArticlesList { + tagged = tag + , full = False + , featured = limit articlesFeatured + }) + , (basePath "all.html", ArticlesList { + tagged = tag + , full = True + , featured = articlesFeatured + }) + ] + +generateArticles :: [Article] -> ReaderT Blog IO () +generateArticles = mapM_ $ \article -> do + filePath <- ( urlPath article <.> "html") <$> (Blog.get root) + (renderTextT . Dom.page $ Dom.article article) + >>= liftIO . TextIO.writeFile filePath + +generateCollection :: Collection -> ReaderT Blog IO () +generateCollection (Collection {articlesFeatured = []}) = return () +generateCollection aCollection = do + liftIO . createDirectoryIfMissing False $ basePath aCollection + articlesLists aCollection + >>= (mapM_ $ \(filePath, articlesList) -> + (renderTextT . Dom.page $ Dom.articlesList articlesList) + >>= liftIO . TextIO.writeFile filePath + ) generate :: ReaderT Blog IO () generate = do - Blog {root, articles, tags} <- ask - generateCollection (Nothing, root, sortByDate $ Map.elems articles) - forM_ (Map.toList $ tags) $ \(tag, tagged) -> - generateCollection (Just tag, root tag, sortByDate $ getArticles tagged articles) + Blog {articles, tags} <- ask + generateArticles $ Map.elems articles + collection (Map.elems articles) Nothing >>= generateCollection + forM (Map.toList tags) $ + \(tag, tagged) -> collection (getArticles tagged articles) $ Just tag + >>= mapM_ generateCollection where getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged) - sortByDate = sortOn (Down . modificationTime . fileStatus) diff --git a/src/Main.hs b/src/Main.hs index 3da85d7..58c5402 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,8 +1,7 @@ -{- LANGUAGE NamedFieldPuns #-} module Main where import qualified Arguments (get) -import qualified Blog (get) +import qualified Blog (build) import qualified HTML (generate) import qualified JSON (generate) import Control.Monad.Reader (runReaderT) @@ -10,7 +9,7 @@ import Control.Monad.Reader (runReaderT) main :: IO () main = do Arguments.get - >>= Blog.get + >>= Blog.build >>= runReaderT (do HTML.generate JSON.generate