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

Split Dom templating and HTML generation process, make a separate module for articles to start scanning their content a bit

This commit is contained in:
Tissevert 2019-02-02 23:23:05 +01:00
parent f81776d3de
commit c8a9a6c9eb
7 changed files with 190 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hablo.cabal
View File

@ -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

16
src/Arguments.hs
View File

@ -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

41
src/Article.hs Normal file
View File

@ -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
}
)

72
src/Blog.hs
View File

@ -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

99
src/Dom.hs
View File

@ -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 "/" ("/" </>)

53
src/HTML.hs Normal file
View File

@ -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)

4
src/Main.hs
View File

@ -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
)