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

This commit is contained in:
Tissevert 2019-02-07 17:51:06 +01:00
parent 7beb159a24
commit 515fb14914
6 changed files with 81 additions and 27 deletions

View File

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

View File

@ -2,14 +2,17 @@
{-# LANGUAGE FlexibleContexts #-}
module Blog (
Blog(..)
, Skin(..)
, build
, get
) where
import Arguments (Arguments(bannerPath, blogName, headPath, sourceDir))
import qualified Arguments (previewArticlesCount, previewLinesCount)
import Arguments (Arguments(sourceDir))
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 previewLinesCount = Arguments.previewLinesCount arguments
articles <- findArticles previewLinesCount articlesPath
let name = maybe (takeFileName $ dropTrailingPathSeparator root) id $ Arguments.name arguments
skin <- Skin.build name arguments
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

49
src/Blog/Skin.hs Normal file
View File

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

View File

@ -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 "site_name" blogName
og "image" =<< (Blog.get $skin.$cardImage)
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

View File

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

6
src/Pretty.hs Normal file
View File

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