Add a module to handle pages with articles list and generate HTML pages for articles too

This commit is contained in:
Tissevert 2019-02-03 22:56:21 +01:00
parent 7e4cde152c
commit 38846e1add
6 changed files with 107 additions and 70 deletions

View file

@ -20,6 +20,7 @@ executable hablo
main-is: Main.hs main-is: Main.hs
other-modules: Arguments other-modules: Arguments
, Article , Article
, ArticlesList
, Blog , Blog
, Dom , Dom
, HTML , HTML

View file

@ -6,16 +6,16 @@ module Article (
) where ) where
import Control.Monad.State (evalState, modify, state) import Control.Monad.State (evalState, modify, state)
import Data.Text (Text, pack) import System.FilePath (dropExtension)
import System.FilePath ((</>))
import System.Posix.Types (FileID) import System.Posix.Types (FileID)
import System.Posix.Files (FileStatus, getFileStatus, fileID) import System.Posix.Files (FileStatus, getFileStatus, fileID)
data Article = Article { data Article = Article {
urlPath :: Text urlPath :: String
, fileStatus :: FileStatus , fileStatus :: FileStatus
, title :: String , title :: String
, preview :: String , preview :: String
, fullContents :: String
} }
getTitle :: [String] -> (String, [String]) getTitle :: [String] -> (String, [String])
@ -38,14 +38,16 @@ parseBegining linesCount = evalState (do
at :: Int -> FilePath -> IO (FileID, Article) at :: Int -> FilePath -> IO (FileID, Article)
at linesCount filePath = do at linesCount filePath = do
fileStatus <- getFileStatus filePath fileStatus <- getFileStatus filePath
(title, preview) <- parseBegining linesCount <$> readFile filePath fullContents <- readFile filePath
let (title, preview) = parseBegining linesCount fullContents
return ( return (
fileID fileStatus fileID fileStatus
, Article { , Article {
urlPath = pack $ "/" </> filePath urlPath = dropExtension filePath
, fileStatus , fileStatus
, title , title
, preview , preview
, fullContents
} }
) )

View file

@ -1,6 +1,8 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
module Blog ( module Blog (
Blog(..) Blog(..)
, build
, get , get
) where ) where
@ -9,6 +11,7 @@ import qualified Arguments (previewArticlesCount, previewLinesCount)
import Article (Article) import Article (Article)
import qualified Article (at) import qualified Article (at)
import Control.Monad ((>=>), filterM, forM) import Control.Monad ((>=>), filterM, forM)
import Control.Monad.Reader (MonadReader, ask)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map (fromList, member) import qualified Data.Map as Map (fromList, member)
import Data.Set (Set) import Data.Set (Set)
@ -31,6 +34,9 @@ data Blog = Blog {
, customHead :: Maybe String , customHead :: Maybe String
} }
get :: MonadReader Blog m => (Blog -> a) -> m a
get = (<$> ask)
find :: FilePath -> IO [FilePath] find :: FilePath -> IO [FilePath]
find path = find path =
fmap (path </>) <$> listDirectory path fmap (path </>) <$> listDirectory path
@ -58,8 +64,8 @@ tagged collection path = do
else return Set.empty else return Set.empty
return (takeFileName path, foldl Set.union Set.empty fileIDs) return (takeFileName path, foldl Set.union Set.empty fileIDs)
get :: Arguments -> IO Blog build :: Arguments -> IO Blog
get arguments = withCurrentDirectory root $ do build arguments = withCurrentDirectory root $ do
let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName arguments let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName arguments
let previewLinesCount = Arguments.previewLinesCount arguments let previewLinesCount = Arguments.previewLinesCount arguments
articles <- findArticles previewLinesCount articlesPath articles <- findArticles previewLinesCount articlesPath

View file

@ -1,33 +1,27 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Dom ( module Dom (
Page(..) article
, render , articlesList
, page
) where ) where
import Article (Article(..)) import Article (Article(..))
import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle)
import Blog (Blog(..)) 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 qualified Data.Map as Map (keys)
import Data.Text (pack, empty) import Data.Text (pack, empty)
import Lucid import Lucid
import System.FilePath.Posix ((</>)) import System.FilePath.Posix ((</>), (<.>))
type HtmlGenerator = HtmlT (ReaderT Blog IO) 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 -> HtmlGenerator ()
previewArticle (Article {urlPath, title, preview}) = previewArticle (Article {urlPath, title, preview}) =
article_ (do article_ (do
a_ [href_ urlPath] . h3_ $ toHtml title a_ [href_ . pack $ "/" </> urlPath <.> "html"] . h3_ $ toHtml title
pre_ $ toHtml preview pre_ $ toHtml preview
) )
@ -36,42 +30,47 @@ tag tagName = li_ (a_ [href_ $ pack ("/" </> tagName)] $ toHtml tagName)
banner :: HtmlGenerator () banner :: HtmlGenerator ()
banner = do banner = do
maybe defaultBanner toHtmlRaw =<< blog customBanner maybe defaultBanner toHtmlRaw =<< Blog.get customBanner
defaultBanner :: HtmlGenerator () defaultBanner :: HtmlGenerator ()
defaultBanner = do defaultBanner = do
div_ [id_ "header"] ( div_ [id_ "header"] (
a_ [href_ "/"] ( a_ [href_ "/"] (
h1_ . toHtml =<< blog name h1_ . toHtml =<< Blog.get name
) )
) )
render :: Page -> HtmlGenerator () article :: Article -> HtmlGenerator ()
render (Page {category, full, articlesFeatured}) = 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 doctypehtml_ (do
head_ (do head_ (do
meta_ [charset_ "utf-8"] meta_ [charset_ "utf-8"]
title_ . toHtml =<< blog name title_ . toHtml =<< Blog.get name
script_ [src_ "/UnitJS/async.js"] empty script_ [src_ "/UnitJS/async.js"] empty
script_ [src_ "/UnitJS/dom.js"] empty script_ [src_ "/UnitJS/dom.js"] empty
maybe (toHtml empty) toHtmlRaw =<< blog customHead maybe (toHtml empty) toHtmlRaw =<< Blog.get customHead
) )
body_ (do body_ (do
banner banner
div_ [id_ "navigator"] (do div_ [id_ "navigator"] (do
h2_ "Tags" h2_ "Tags"
ul_ . mapM_ tag . Map.keys =<< blog tags ul_ . mapM_ tag . Map.keys =<< Blog.get 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)
) )
div_ [id_ "contents"] contents
) )
) )
where
pageTitle =
(if full then "All" else "Latest") ++ " articles" ++ maybe "" (" tagged " ++) category
url = maybe "/" ("/" </>)

View file

@ -5,8 +5,10 @@ module HTML (
) where ) where
import Article(Article(..)) import Article(Article(..))
import ArticlesList (ArticlesList(..))
import Blog (Blog(..)) import Blog (Blog(..))
import Control.Monad (forM_) import qualified Blog (get)
import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (MonadReader(..), ReaderT) import Control.Monad.Reader (MonadReader(..), ReaderT)
import Data.List (sortOn) import Data.List (sortOn)
@ -14,40 +16,68 @@ import qualified Data.Map as Map (elems, filterWithKey, toList)
import Data.Ord (Down(..)) import Data.Ord (Down(..))
import qualified Data.Set as Set (member) import qualified Data.Set as Set (member)
import qualified Data.Text.Lazy.IO as TextIO (writeFile) import qualified Data.Text.Lazy.IO as TextIO (writeFile)
import Dom (Page(..), render) import qualified Dom (article, articlesList, page)
import Lucid import Lucid
import System.Directory (createDirectoryIfMissing) import System.Directory (createDirectoryIfMissing)
import System.FilePath.Posix ((</>)) import System.FilePath.Posix ((</>), (<.>))
import System.Posix.Files (modificationTime) import System.Posix.Files (modificationTime)
generateCollection :: (Maybe String, FilePath, [Article]) -> ReaderT Blog IO () data Collection = Collection {
generateCollection (_, _, []) = return () articlesFeatured :: [Article]
generateCollection (category, path, articlesFeatured) = do , basePath :: FilePath
blog <- ask , tag :: Maybe String
liftIO $ createDirectoryIfMissing False path }
forM_ (pages $ previewArticlesCount blog) $ \(filePath, page) ->
renderTextT (render page) collection :: Monad m => [Article] -> Maybe String -> ReaderT Blog m Collection
>>= liftIO . TextIO.writeFile filePath collection articlesFeatured tag = do
root <- Blog.get root
return $ Collection {
articlesFeatured = sortByDate articlesFeatured
, basePath = maybe root (root </>) tag
, tag
}
where where
pages articlesCount = [ sortByDate = sortOn (Down . modificationTime . fileStatus)
(path </> "all.html", Page {
category articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)]
, full = True articlesLists (Collection {articlesFeatured, basePath, tag}) = do
, articlesFeatured limit <- take <$> Blog.get previewArticlesCount
}) return [
, (path </> "index.html", Page { (basePath </> "index.html", ArticlesList {
category tagged = tag
, full = False , full = False
, articlesFeatured = take articlesCount articlesFeatured , 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 :: ReaderT Blog IO ()
generate = do generate = do
Blog {root, articles, tags} <- ask Blog {articles, tags} <- ask
generateCollection (Nothing, root, sortByDate $ Map.elems articles) generateArticles $ Map.elems articles
forM_ (Map.toList $ tags) $ \(tag, tagged) -> collection (Map.elems articles) Nothing >>= generateCollection
generateCollection (Just tag, root </> tag, sortByDate $ getArticles tagged articles) forM (Map.toList tags) $
\(tag, tagged) -> collection (getArticles tagged articles) $ Just tag
>>= mapM_ generateCollection
where where
getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged) getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged)
sortByDate = sortOn (Down . modificationTime . fileStatus)

View file

@ -1,8 +1,7 @@
{- LANGUAGE NamedFieldPuns #-}
module Main where module Main where
import qualified Arguments (get) import qualified Arguments (get)
import qualified Blog (get) import qualified Blog (build)
import qualified HTML (generate) import qualified HTML (generate)
import qualified JSON (generate) import qualified JSON (generate)
import Control.Monad.Reader (runReaderT) import Control.Monad.Reader (runReaderT)
@ -10,7 +9,7 @@ import Control.Monad.Reader (runReaderT)
main :: IO () main :: IO ()
main = do main = do
Arguments.get Arguments.get
>>= Blog.get >>= Blog.build
>>= runReaderT (do >>= runReaderT (do
HTML.generate HTML.generate
JSON.generate JSON.generate