From c8a9a6c9eb76edf7b8593ce589ad2985c8bfdb14 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sat, 2 Feb 2019 23:23:05 +0100 Subject: [PATCH] Split Dom templating and HTML generation process, make a separate module for articles to start scanning their content a bit --- hablo.cabal | 2 + src/Arguments.hs | 16 ++++++-- src/Article.hs | 41 ++++++++++++++++++++ src/Blog.hs | 72 +++++++++++++++++++---------------- src/Dom.hs | 99 ++++++++++++++++++++---------------------------- src/HTML.hs | 53 ++++++++++++++++++++++++++ src/Main.hs | 4 +- 7 files changed, 190 insertions(+), 97 deletions(-) create mode 100644 src/Article.hs create mode 100644 src/HTML.hs diff --git a/hablo.cabal b/hablo.cabal index a70524c..eb9cac6 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -19,8 +19,10 @@ extra-source-files: CHANGELOG.md executable hablo main-is: Main.hs other-modules: Arguments + , Article , Blog , Dom + , HTML , JSON -- other-extensions: build-depends: aeson diff --git a/src/Arguments.hs b/src/Arguments.hs index db1d16a..28b7e28 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -13,7 +13,8 @@ import System.FilePath.Posix (dropTrailingPathSeparator, isValid) data Arguments = Arguments { sourceDir :: FilePath , blogName :: Maybe String - , previewCountArg :: Int + , previewArticlesCount :: Int + , previewLinesCount :: Int , bannerPath :: Maybe FilePath , headPath :: Maybe FilePath } @@ -29,12 +30,19 @@ parseArguments = Arguments <> help "name of the blog" ) <*> option auto ( - metavar "PREVIEW_COUNT" + metavar "PREVIEW_ARTICLES_COUNT" <> value 3 - <> short 'p' - <> long "preview-count" + <> short 'a' + <> long "preview-articles" <> help "number of articles listed on the page of each category" ) + <*> option auto ( + metavar "PREVIEW_LINES_COUNT" + <> value 10 + <> short 'l' + <> long "preview-lines" + <> help "number of lines to display in articles preview" + ) <*> option (optional filePath) ( metavar "BANNER_PATH" <> value Nothing diff --git a/src/Article.hs b/src/Article.hs new file mode 100644 index 0000000..3b8c9b3 --- /dev/null +++ b/src/Article.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NamedFieldPuns #-} +{- LANGUAGE OverloadedStrings #-} +module Article ( + Article(..) + , at + ) where + +import Control.Monad.State (evalState, state) +import Data.Text (Text, pack) +import System.FilePath (()) +import System.Posix.Types (FileID) +import System.Posix.Files (FileStatus, getFileStatus, fileID) + +data Article = Article { + urlPath :: Text + , fileStatus :: FileStatus + , title :: String + , preview :: String + } + +parseBegining :: Int -> String -> (String, String) +parseBegining linesCount = evalState (do + first <- state $ splitAt 1 + second <- state $ splitAt linesCount + return (unlines first, unlines second) + ) . lines + +at :: Int -> FilePath -> IO (FileID, Article) +at linesCount filePath = do + fileStatus <- getFileStatus filePath + (title, preview) <- parseBegining linesCount <$> readFile filePath + return ( + fileID fileStatus + , Article { + urlPath = pack $ "/" filePath + , fileStatus + , title + , preview + } + ) + diff --git a/src/Blog.hs b/src/Blog.hs index 0d91bcc..77d9db6 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -1,75 +1,81 @@ {-# LANGUAGE NamedFieldPuns #-} module Blog ( - Article(..) - , Blog(..) + Blog(..) , get ) where -import Arguments (Arguments(..)) +import Arguments (Arguments(bannerPath, blogName, headPath, sourceDir)) +import qualified Arguments (previewArticlesCount, previewLinesCount) +import Article (Article) +import qualified Article (at) import Control.Monad ((>=>), filterM, forM) -import Control.Monad.IO.Class (MonadIO(..)) import Data.Map (Map) -import Data.Text (Text, pack) import qualified Data.Map as Map (fromList, member) import Data.Set (Set) import qualified Data.Set as Set (empty, null, singleton, union) import System.Directory (doesFileExist, listDirectory, withCurrentDirectory) import System.FilePath ((), dropTrailingPathSeparator, splitFileName, takeExtension, takeFileName) import System.Posix.Types (FileID) -import System.Posix.Files (FileStatus, getFileStatus, fileID) - -data Article = Article { - urlPath :: Text - , fileStatus :: FileStatus - } +import System.Posix.Files (getFileStatus, fileID) type Collection = Map FileID Article data Blog = Blog { articles :: Collection , name :: String - , previewCount :: Int + , previewArticlesCount :: Int + , previewLinesCount :: Int , root :: FilePath , tags :: Map String (Set FileID) + , customBanner :: Maybe String + , customHead :: Maybe String } -find :: MonadIO m => FilePath -> m [FilePath] +find :: FilePath -> IO [FilePath] find path = - prefix <$> liftIO (listDirectory path) - where - prefix = ((path ) <$>) + fmap (path ) <$> listDirectory path -article :: MonadIO m => FilePath -> m (FileID, Article) -article filePath = do - fileStatus <- liftIO $ getFileStatus filePath - return (fileID fileStatus, Article { urlPath = pack $ "/" filePath, fileStatus }) - -findArticles :: MonadIO m => FilePath -> m (Map FileID Article) -findArticles = - find >=> filterM isMarkDownFile >=> mapM article >=> return . Map.fromList +findArticles :: Int -> FilePath -> IO (Map FileID Article) +findArticles linesCount = + find + >=> filterM isMarkDownFile + >=> mapM (Article.at linesCount) + >=> return . Map.fromList where isMarkDownFile path = do let correctExtension = takeExtension path == ".md" - (correctExtension &&) <$> liftIO (doesFileExist path) + (correctExtension &&) <$> doesFileExist path -tagged :: MonadIO m => Collection -> FilePath -> m (String, Set FileID) +tagged :: Collection -> FilePath -> IO (String, Set FileID) tagged collection path = do links <- find path fileIDs <- forM links $ \link -> do - fileExists <- liftIO $ doesFileExist link + fileExists <- doesFileExist link if fileExists then do - inode <- fileID <$> liftIO (getFileStatus link) + inode <- fileID <$> getFileStatus link return $ if Map.member inode collection then Set.singleton inode else Set.empty else return Set.empty return (takeFileName path, foldl Set.union Set.empty fileIDs) get :: Arguments -> IO Blog -get (Arguments {sourceDir, blogName, previewCountArg}) = withCurrentDirectory root $ do - let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName - articles <- findArticles articlesPath +get arguments = withCurrentDirectory root $ do + let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName arguments + let previewLinesCount = Arguments.previewLinesCount arguments + articles <- findArticles previewLinesCount articlesPath tags <- Map.fromList . filter (not . Set.null . snd) <$> (find (articlesPath "tags") >>= mapM (articles `tagged`)) - return $ Blog { articles , name, previewCount = previewCountArg, root, tags } + customBanner <- mapM readFile $ bannerPath arguments + customHead <- mapM readFile $ headPath arguments + return $ Blog { + articles + , name + , previewArticlesCount = Arguments.previewArticlesCount arguments + , previewLinesCount + , root + , tags + , customBanner + , customHead + } where - (root, articlesPath) = splitFileName sourceDir + (root, articlesPath) = splitFileName $ sourceDir arguments diff --git a/src/Dom.hs b/src/Dom.hs index be787fb..c0e84a6 100644 --- a/src/Dom.hs +++ b/src/Dom.hs @@ -1,94 +1,77 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Dom ( - generate + Page(..) + , render ) where -import Blog (Article(..), Blog(..)) -import Control.Monad (forM_) -import Control.Monad.IO.Class (MonadIO(..)) +import Article (Article(..)) +import Blog (Blog(..)) import Control.Monad.Reader (MonadReader(..), ReaderT) -import Data.List (sortOn) -import qualified Data.Map as Map (elems, filterWithKey, keys, toList) -import Data.Ord (Down(..)) -import qualified Data.Set as Set (member) +import qualified Data.Map as Map (keys) import Data.Text (pack, empty) import Lucid -import System.Directory (createDirectoryIfMissing) import System.FilePath.Posix (()) -import System.Posix.Files (modificationTime) + +type HtmlGenerator = HtmlT (ReaderT Blog IO) data Page = Page { category :: Maybe String , full :: Bool - , filePath :: FilePath , articlesFeatured :: [Article] } -previewArticle :: Article -> Html () -previewArticle (Article {urlPath}) = +blog :: (Blog -> a) -> HtmlGenerator a +blog = (<$> ask) + +previewArticle :: Article -> HtmlGenerator () +previewArticle (Article {urlPath, title, preview}) = article_ (do - h1_ $ a_ [href_ urlPath] "Some Article" - pre_ $ toHtml urlPath + a_ [href_ urlPath] . h3_ $ toHtml title + pre_ $ toHtml preview ) -showTag :: String -> Html () -showTag tag = li_ (a_ [href_ $ pack ("/" tag)] $ toHtml tag) +tag :: String -> HtmlGenerator () +tag tagName = li_ (a_ [href_ $ pack ("/" tagName)] $ toHtml tagName) -render :: Page -> Blog -> Html () -render (Page {category, full, articlesFeatured}) blog = +banner :: HtmlGenerator () +banner = do + maybe defaultBanner toHtmlRaw =<< blog customBanner + +defaultBanner :: HtmlGenerator () +defaultBanner = do + div_ [id_ "header"] ( + a_ [href_ "/"] ( + h1_ . toHtml =<< blog name + ) + ) + +render :: Page -> HtmlGenerator () +render (Page {category, full, articlesFeatured}) = doctypehtml_ (do head_ (do meta_ [charset_ "utf-8"] - title_ . toHtml $ name blog + title_ . toHtml =<< blog name script_ [src_ "/UnitJS/async.js"] empty script_ [src_ "/UnitJS/dom.js"] empty + maybe (toHtml empty) toHtmlRaw =<< blog customHead ) body_ (do - div_ [id_ "header"] (return ()) + banner div_ [id_ "navigator"] (do - h1_ "Tags" - ul_ (mapM_ showTag (Map.keys $ tags blog)) + h2_ "Tags" + ul_ . mapM_ tag . Map.keys =<< blog tags ) div_ [id_ "contents"] (do - h1_ $ toHtml pageTitle + 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) ) ) ) where pageTitle = - if full then "All" else "Latest" ++ " articles" ++ maybe "" (" tagged " ++) category - -generateCollection :: (Maybe String, FilePath, [Article]) -> ReaderT Blog IO () -generateCollection (_, _, []) = return () -generateCollection (category, path, articlesFeatured) = do - blog <- ask - liftIO $ createDirectoryIfMissing False path - forM_ (pages $ previewCount blog) $ \page -> - liftIO $ renderToFile (filePath page) (render page blog) - where - pages articlesCount = [ - Page { - category - , full = True - , filePath = path "all.html" - , articlesFeatured - } - , Page { - category - , full = False - , filePath = path "index.html" - , articlesFeatured = take articlesCount articlesFeatured - } - ] - -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) - where - getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged) - sortByDate = sortOn (Down . modificationTime . fileStatus) + (if full then "All" else "Latest") ++ " articles" ++ maybe "" (" tagged " ++) category + url = maybe "/" ("/" ) diff --git a/src/HTML.hs b/src/HTML.hs new file mode 100644 index 0000000..2951e7a --- /dev/null +++ b/src/HTML.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module HTML ( + generate + ) where + +import Article(Article(..)) +import Blog (Blog(..)) +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (MonadReader(..), ReaderT) +import Data.List (sortOn) +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 Lucid +import System.Directory (createDirectoryIfMissing) +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 + where + pages articlesCount = [ + (path "all.html", Page { + category + , full = True + , articlesFeatured + }) + , (path "index.html", Page { + category + , full = False + , articlesFeatured = take articlesCount articlesFeatured + }) + ] + +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) + 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 53cd507..3da85d7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,7 @@ module Main where import qualified Arguments (get) import qualified Blog (get) -import qualified Dom (generate) +import qualified HTML (generate) import qualified JSON (generate) import Control.Monad.Reader (runReaderT) @@ -12,6 +12,6 @@ main = do Arguments.get >>= Blog.get >>= runReaderT (do - Dom.generate + HTML.generate JSON.generate )