Take a part of Blog's configuration into a separate Skin module, add syntactic sugar and use the result in generation modules

hablo.cabal

@@ -23,12 +23,14 @@ executable hablo
                      , Article
                      , ArticlesList
                      , Blog
+                     , Blog.Skin
                      , Dom
                      , Files
                      , HTML
                      , JS
                      , JSON
                      , Paths_hablo
+                     , Pretty
   -- other-extensions:
   build-depends:       aeson
                      , base ^>=4.12.0.0

src/Blog.hs

@@ -2,14 +2,17 @@
 {-# LANGUAGE FlexibleContexts #-}
 module Blog (
       Blog(..)
+    , Skin(..)
     , build
     , get
   ) where
 
-import Arguments (Arguments(bannerPath, blogName, headPath, sourceDir))
+import Arguments (Arguments(sourceDir))
-import qualified Arguments (previewArticlesCount, previewLinesCount)
+import qualified Arguments (name)
 import Article (Article)
 import qualified Article (at)
+import Blog.Skin (Skin(..))
+import qualified Blog.Skin as Skin (build)
 import Control.Monad ((>=>), filterM, forM)
 import Control.Monad.Reader (MonadReader, ask)
 import Data.Map (Map)
@@ -27,12 +30,9 @@ type Collection = Map FileID Article
 data Blog = Blog {
       articles :: Collection
     , name :: String
-    , previewArticlesCount :: Int
-    , previewLinesCount :: Int
     , root :: FilePath
+    , skin :: Skin
     , tags :: Map String (Set FileID)
-    , customBanner :: Maybe String
-    , customHead :: Maybe String
   }
 
 get :: MonadReader Blog m => (Blog -> a) -> m a
@@ -63,22 +63,17 @@ tagged collection path = do
 
 build :: Arguments -> IO Blog
 build arguments = withCurrentDirectory root $ do
-  let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ blogName arguments
+  let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ Arguments.name arguments
-  let previewLinesCount = Arguments.previewLinesCount arguments
+  skin <- Skin.build name arguments
-  articles <- findArticles previewLinesCount articlesPath
+  articles <- findArticles (previewLinesCount skin) articlesPath
   tags <- Map.fromList . filter (not . Set.null . snd)
     <$> (Files.find (articlesPath </> "tags") >>= mapM (articles `tagged`))
-  customBanner <- mapM readFile $ bannerPath arguments
-  customHead <- mapM readFile $ headPath arguments
   return $ Blog {
         articles
       , name
-      , previewArticlesCount = Arguments.previewArticlesCount arguments
-      , previewLinesCount
       , root
+      , skin
       , tags
-      , customBanner
-      , customHead
     }
   where
     (root, articlesPath) = splitFileName $ sourceDir arguments

src/Blog/Skin.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Blog.Skin (
+      Skin(..)
+    , build
+  ) where
+
+import Arguments (Arguments)
+import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount)
+import Control.Monad (filterM)
+import Data.Maybe (listToMaybe)
+import Prelude hiding (head)
+import System.Directory (doesFileExist)
+import System.FilePath ((</>), (<.>))
+
+data Skin = Skin {
+      banner :: Maybe String
+    , cardImage :: FilePath
+    , favicon :: Maybe FilePath
+    , head :: Maybe String
+    , previewArticlesCount :: Int
+    , previewLinesCount :: Int
+  }
+
+findFavicon :: Arguments -> IO (Maybe FilePath)
+findFavicon arguments =
+  case Arguments.favicon arguments of
+    Just path -> return $ Just path
+    _ -> fmap absolute . listToMaybe <$> filterM doesFileExist pathsToCheck
+  where
+    directories = [".", "image", "images", "pictures", "skin", "static"]
+    extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]
+    pathsToCheck = [ dir </> "favicon" <.> ext | dir <- directories, ext <- extensions ]
+    absolute ('.':path) = path
+    absolute path = "/" </> path
+
+build :: String -> Arguments -> IO Skin
+build blogName arguments = do
+  let cardImage = maybe ("/image" </> blogName <.> "png") id $ Arguments.cardImage arguments
+  banner <- mapM readFile $ Arguments.bannerPath arguments
+  favicon <- findFavicon arguments
+  head <- mapM readFile $ Arguments.headPath arguments
+  return $ Skin {
+        banner
+      , cardImage
+      , favicon
+      , head
+      , previewArticlesCount = Arguments.previewArticlesCount arguments
+      , previewLinesCount = Arguments.previewLinesCount arguments
+    }

src/Dom.hs

@@ -6,7 +6,7 @@ module Dom (
 
 import Article (Article(..))
 import ArticlesList (ArticlesList(..), otherLink, otherUrl, pageTitle)
-import Blog (Blog(..))
+import Blog (Blog(..), Skin(..))
 import qualified Blog (get)
 import Control.Monad.Reader (ReaderT)
 import qualified Data.Map as Map (keys)
@@ -14,6 +14,8 @@ import Data.Monoid ((<>))
 import Data.Text (pack, empty)
 import Lucid
 import Lucid.Base (makeAttribute)
+import Prelude hiding (head)
+import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
 
 type HtmlGenerator = HtmlT (ReaderT Blog IO)
@@ -45,11 +47,10 @@ instance Page ArticlesList where
 
 makeCard :: String -> String -> HtmlGenerator ()
 makeCard title description = do
-  blogName <- Blog.get name
   og "title" title
   og "description" description
-  og "image" $ "/image" </> blogName <.> "png"
+  og "image" =<< (Blog.get $skin.$cardImage)
-  og "site_name" blogName
+  og "site_name" =<< Blog.get name
   where
     og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ $ pack value]
 
@@ -66,10 +67,6 @@ previewArticle (Article {urlPath, title, preview}) =
 tag :: String -> HtmlGenerator ()
 tag tagName = li_ (navigationA [href_ $ pack ("/" </> tagName)] $ toHtml tagName)
 
-banner :: HtmlGenerator ()
-banner = do
-  maybe defaultBanner toHtmlRaw =<< Blog.get customBanner
-
 defaultBanner :: HtmlGenerator ()
 defaultBanner = do
   div_ [id_ "header"] (
@@ -78,6 +75,9 @@ defaultBanner = do
         )
     )
 
+faviconLink :: FilePath -> HtmlGenerator ()
+faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"]
+
 page :: Page a => a -> HtmlGenerator ()
 page aPage =
   doctypehtml_ (do
@@ -87,11 +87,12 @@ page aPage =
           script_ [src_ "/UnitJS/async.js"] empty
           script_ [src_ "/UnitJS/dom.js"] empty
           script_ [src_ "/js/hablo.js"] empty
+          maybe (toHtml empty) faviconLink =<< (Blog.get $skin.$favicon)
           card aPage
-          maybe (toHtml empty) toHtmlRaw =<< Blog.get customHead
+          (Blog.get $skin.$head) >>= maybe (toHtml empty) toHtmlRaw
         )
       body_ (do
-          banner
+          (Blog.get $skin.$banner) >>= maybe defaultBanner toHtmlRaw
           div_ [id_ "navigator"] (do
               h2_ "Tags"
               ul_ . mapM_ tag . Map.keys =<< Blog.get tags

src/HTML.hs

@@ -6,7 +6,7 @@ module HTML (
 
 import Article(Article(..))
 import ArticlesList (ArticlesList(..))
-import Blog (Blog(..))
+import Blog (Blog(..), Skin(..))
 import qualified Blog (get)
 import Control.Monad (forM)
 import Control.Monad.IO.Class (MonadIO(..))
@@ -18,6 +18,7 @@ import qualified Data.Set as Set (member)
 import qualified Data.Text.Lazy.IO as TextIO (writeFile)
 import Dom (page)
 import Lucid
+import Pretty ((.$))
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath.Posix ((</>), (<.>))
 import System.Posix.Files (modificationTime)
@@ -41,7 +42,7 @@ collection articlesFeatured tag = do
 
 articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)]
 articlesLists (Collection {articlesFeatured, basePath, tag}) = do
-  limit <- take <$> Blog.get previewArticlesCount
+  limit <- take <$> (Blog.get $skin.$previewArticlesCount)
   return [
         (basePath </> "index.html", ArticlesList {
               tagged = tag

src/Pretty.hs

@@ -0,0 +1,6 @@
+module Pretty (
+    (.$)
+  ) where
+
+(.$) :: (a -> b) -> (b -> c) -> (a -> c)
+(.$) f g = g . f