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

hablo.cabal

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

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 (dropExtension)
-import System.FilePath ((</>))
 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
           }
     )
 

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
+build :: Arguments -> IO Blog
-get arguments = withCurrentDirectory root $ do
+build arguments = withCurrentDirectory root $ do
   let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName arguments
   let previewLinesCount = Arguments.previewLinesCount arguments
   articles <- findArticles previewLinesCount articlesPath

src/Dom.hs

@@ -1,33 +1,27 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Dom (
-      Page(..)
+      article
-    , render
+    , 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 ()
+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
       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
+              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 "/" ("/" </>)

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 ()
+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
-    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 = 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
     getArticles tagged = Map.elems . Map.filterWithKey (\k _ -> Set.member k tagged)
-    sortByDate = sortOn (Down . modificationTime . fileStatus)

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