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

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

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

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

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

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

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)

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
   )