From 19b3694d06beeca7e3358c457f194da2e1653aa7 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Tue, 9 Jun 2020 17:52:16 +0200 Subject: [PATCH] =?UTF-8?q?Directly=20store=20each=20Markdown=20content's?= =?UTF-8?q?=20path=20in=20the=20data=20structure=20to=20save=20having=20to?= =?UTF-8?q?=20re-build=20the=20same=20concatenation=20again=20and=20again?= =?UTF-8?q?=20for=20all=20the=20various=20outputs=20where=20the=20path=20m?= =?UTF-8?q?atters=20;=20also=20handles=20elegantly=20the=20=C2=ABissue?= =?UTF-8?q?=C2=BB=20of=20pagesPath=20being=20a=20Maybe=20FilePath=20becaus?= =?UTF-8?q?e=20pages=20are=20optional?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Blog/Skin.hs | 2 +- src/DOM.hs | 12 +++++++----- src/DOM/Card.hs | 11 ++++++----- src/HTML.hs | 4 ++-- src/Markdown.hs | 14 ++++++++------ src/RSS.hs | 7 +++---- 6 files changed, 27 insertions(+), 23 deletions(-) diff --git a/src/Blog/Skin.hs b/src/Blog/Skin.hs index aa688c4..3ac39b8 100644 --- a/src/Blog/Skin.hs +++ b/src/Blog/Skin.hs @@ -36,7 +36,7 @@ instance ToJSON Skin where findImage :: String -> Maybe FilePath -> IO (Maybe FilePath) findImage _ (Just path) = return . Just $ absoluteLink path findImage name Nothing = - fmap absoluteLink . listToMaybe <$> filterM doesFileExist pathsToCheck + listToMaybe <$> filterM doesFileExist pathsToCheck where directories = [".", "image", "images", "pictures", "skin", "static"] extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"] diff --git a/src/DOM.hs b/src/DOM.hs index 38755d4..8351f59 100644 --- a/src/DOM.hs +++ b/src/DOM.hs @@ -9,7 +9,7 @@ import qualified Article (preview) import ArticlesList ( ArticlesList(..), description, getArticles, otherURL, rssLinkTexts ) -import Blog (Blog(..), Path(..), Skin(..), URL(..), template) +import Blog (Blog(..), Skin(..), URL(..), template) import Control.Monad.Reader (ReaderT, asks) import qualified Data.Map as Map (keys) import Data.Text (pack, empty) @@ -24,7 +24,7 @@ import Lucid ( import Markdown (Markdown(..)) import Prelude hiding (head, lookup) import Pretty ((.$)) -import System.FilePath.Posix ((), (<.>)) +import System.FilePath.Posix ((<.>)) type HtmlGenerator = HtmlT (ReaderT Blog IO) @@ -54,8 +54,8 @@ instance HasContent ArticlesList where rssLink False = return () markdown :: Bool -> Markdown -> HtmlGenerator () -markdown raw (Markdown {key, body, title}) = do - url <- absoluteLink . ( key <.> extension) <$> (asks $path.$articlesPath) +markdown raw (Markdown {key, Markdown.path, body, title}) = + let url = absoluteLink $ path <.> extension in article_ [id_ $ pack key] (do header_ (do a_ [href_ $ pack url] . h1_ $ toHtml title @@ -78,7 +78,9 @@ defaultBanner = do ) faviconLink :: FilePath -> HtmlGenerator () -faviconLink url = link_ [rel_ "shortcut icon", href_ $ pack url, type_ "image/x-icon"] +faviconLink url = link_ [ + rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon" + ] optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator () optional = maybe (return ()) diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index cf4381f..0c9033b 100644 --- a/src/DOM/Card.hs +++ b/src/DOM/Card.hs @@ -21,6 +21,7 @@ import Lucid.Base (makeAttribute) import qualified Markdown (Markdown(..)) import Page (Page(..)) import Pretty ((.$)) +import System.FilePath.Posix ((), (<.>)) class HasCard a where cardType :: Renderer m => a -> m Text @@ -46,7 +47,7 @@ make element siteURL = do og "site_name" =<< (asks $name.$pack) where maybeImage = maybe (return ()) (og "image" . sitePrefix) - sitePrefix = pack . (siteURL ++) + sitePrefix = pack . (siteURL ) instance HasCard Article where cardType _ = return "article" @@ -57,7 +58,7 @@ instance HasCard Article where image (Article (Markdown.Markdown {Markdown.metadata})) = return $ Map.lookup "featuredImage" metadata title = return . Markdown.title . Article.getMarkdown - urlPath = fmap (\t -> "/articles/" ++ t ++ ".html") . title + urlPath (Article markdown) = return $ Markdown.path markdown <.> "html" instance HasCard Page where cardType _ = return "website" @@ -68,7 +69,7 @@ instance HasCard Page where image (Page (Markdown.Markdown {Markdown.metadata})) = return $ Map.lookup "featuredImage" metadata title = return . Markdown.title . Page.getMarkdown - urlPath = fmap (\t -> "/pages/" ++ t ++ ".html") . title + urlPath (Page markdown) = return $ Markdown.path markdown <.> "html" instance HasCard ArticlesList where cardType _ = return "website" @@ -76,6 +77,6 @@ instance HasCard ArticlesList where image _ = return Nothing title (ArticlesList {collection}) = Collection.title collection urlPath al@(ArticlesList {collection}) = - return $ maybe "" ('/':) (tag collection) ++ file + return $ maybe "" id (tag collection) file where - file = '/' : (if full al then "all" else "index") ++ ".html" + file = (if full al then "all" else "index") <.> ".html" diff --git a/src/HTML.hs b/src/HTML.hs index 294e85c..41d81ca 100644 --- a/src/HTML.hs +++ b/src/HTML.hs @@ -29,8 +29,8 @@ articlesLists collection@(Collection {basePath}) = [ generateArticles :: [Article] -> ReaderT Blog IO () generateArticles = mapM_ $ \article -> do - baseDir <- () <$> (asks $path.$root) <*> (asks $path.$articlesPath) - let filePath = baseDir key (Article.getMarkdown article) <.> "html" + let relativePath = Markdown.path (Article.getMarkdown article) <.> "html" + filePath <- ( relativePath) <$> (asks $Blog.path.$root) (renderTextT $ htmlDocument article) >>= liftIO . TextIO.writeFile filePath generateCollection :: Collection -> ReaderT Blog IO () diff --git a/src/Markdown.hs b/src/Markdown.hs index 20491d6..9f209ff 100644 --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -4,7 +4,6 @@ module Markdown ( , Metadata , at , getKey - , parser ) where import Control.Applicative ((<|>)) @@ -15,24 +14,27 @@ import Text.ParserCombinators.Parsec ( ParseError, Parser , () , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf - , oneOf, option, parse, skipMany, sourceLine, string, try + , oneOf, option, parse, skipMany, sourceLine, sourceName, string, try ) type Metadata = Map String String data Markdown = Markdown { key :: String + , path :: String , title :: String , metadata :: Metadata , bodyOffset :: Int , body :: [String] } -parser :: String -> Parser Markdown -parser key = do +parser :: Parser Markdown +parser = do (title, metadata) <- skipMany eol *> (headerP <|> reverseHeaderP) bodyOffset <- skipMany eol *> (pred . sourceLine <$> getPosition) body <- lines <$> many anyChar <* eof - return $ Markdown {key, title, metadata, bodyOffset, body} + inputFile <- sourceName <$> getPosition + let (key, path) = (getKey inputFile, dropExtension inputFile) + return $ Markdown {key, path, title, metadata, bodyOffset, body} where headerP = (,) <$> titleP <* many eol <*> metadataP reverseHeaderP = flip (,) <$> metadataP <* many eol<*> titleP @@ -67,4 +69,4 @@ getKey :: FilePath -> String getKey = dropExtension . takeFileName at :: FilePath -> IO (Either ParseError Markdown) -at filePath = parse (parser (getKey filePath)) filePath <$> readFile filePath +at filePath = parse parser filePath <$> readFile filePath diff --git a/src/RSS.hs b/src/RSS.hs index 0413f60..e7382d4 100644 --- a/src/RSS.hs +++ b/src/RSS.hs @@ -8,7 +8,7 @@ module RSS ( import Article (Article(..)) import ArticlesList (ArticlesList(..), getArticles) import qualified ArticlesList (description) -import Blog (Blog(..), Path(..), Renderer, URL(..)) +import Blog (Blog(urls), Renderer, URL(..)) import Collection (Collection(..), getAll) import qualified Collection (title) import Control.Monad.IO.Class (MonadIO(..)) @@ -58,13 +58,12 @@ pubDate_ :: Term arg result => arg -> result pubDate_ = term "pubDate" articleItem :: MonadReader Blog m => String -> Article -> HtmlT m () -articleItem siteURL (Article (Markdown {key, metadata, title})) = +articleItem siteURL (Article (Markdown {path, metadata, title})) = item_ $ do title_ $ toHtml title - link_ . toHtml =<< link <$> (asks $path.$articlesPath) + link_ $ toHtml (siteURL path <.> "html") pubDate_ . toHtml . rfc822Date $ metadata ! "date" where - link path = siteURL path key <.> "html" rfc822Date = formatTime defaultTimeLocale rfc822DateFormat . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)