diff --git a/hablo.cabal b/hablo.cabal index 86df71e..e8a68e7 100644 --- a/hablo.cabal +++ b/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 diff --git a/src/Blog.hs b/src/Blog.hs index b69629a..c45a4b2 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -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 diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs new file mode 100644 index 0000000..ecece72 --- /dev/null +++ b/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 + } diff --git a/src/Dom.hs b/src/Dom.hs index 3af934f..8df3457 100644 --- a/src/Dom.hs +++ b/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 "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 diff --git a/src/HTML.hs b/src/HTML.hs index 86c1a1a..ea4d5d8 100644 --- a/src/HTML.hs +++ b/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 diff --git a/src/Pretty.hs b/src/Pretty.hs new file mode 100644 index 0000000..f014ccf --- /dev/null +++ b/src/Pretty.hs @@ -0,0 +1,6 @@ +module Pretty ( + (.$) + ) where + +(.$) :: (a -> b) -> (b -> c) -> (a -> c) +(.$) f g = g . f