From 1df95d5091d14f9b32fd37a39b59611ed4acd9c6 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Sun, 7 Jun 2020 23:16:40 +0200 Subject: [PATCH] Start adding a Markdown data type common to Articles and Pages, refactor here and there, will need some more renaming / refactoring in DOM module --- hablo.cabal | 1 + src/Article.hs | 89 +++++++---------------------------------------- src/Blog.hs | 5 +-- src/Collection.hs | 5 +-- src/DOM/Card.hs | 75 ++++++++++++++++++++++++--------------- src/JS.hs | 4 ++- src/JSON.hs | 69 +++++++++++++++++++----------------- src/Markdown.hs | 70 +++++++++++++++++++++++++++++++++++++ src/Page.hs | 10 ++++-- 9 files changed, 184 insertions(+), 144 deletions(-) create mode 100644 src/Markdown.hs diff --git a/hablo.cabal b/hablo.cabal index 723ae24..d367483 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -45,6 +45,7 @@ executable hablo , HTML , JS , JSON + , Markdown , Page , Paths_hablo , Pretty diff --git a/src/Article.hs b/src/Article.hs index 52d62a3..4522839 100644 --- a/src/Article.hs +++ b/src/Article.hs @@ -1,76 +1,24 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} module Article ( Article(..) , at - , getKey , preview ) where import Control.Applicative ((<|>)) -import Data.Map (Map) -import qualified Data.Map as Map (fromList, alter) +import qualified Data.Map as Map (alter) import Data.Time (defaultTimeLocale, getCurrentTimeZone, parseTimeM, timeZoneOffsetString) import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) import Foreign.C.Types (CTime) -import System.FilePath (dropExtension, takeFileName) +import Markdown (Markdown(..), Metadata) +import qualified Markdown (at) import System.Posix.Files (getFileStatus, modificationTime) -import Text.ParserCombinators.Parsec ( - ParseError - , Parser - , () - , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf - , oneOf, option, parse, skipMany, sourceLine, string, try - ) +import Text.ParserCombinators.Parsec (ParseError) -type Metadata = Map String String - -data Article = Article { - key :: String - , title :: String - , metadata :: Metadata - , bodyOffset :: Int - , body :: [String] +newtype Article = Article { + getMarkdown :: Markdown } -type ProtoArticle = (String, Metadata, Int, [String]) - -articleP :: Parser ProtoArticle -articleP = - skipMany eol *> headerP <* skipMany eol <*> lineOffset <*> bodyP - where - headerP = - try ((,,,) <$> titleP <* many eol <*> metadataP) - <|> flip (,,,) <$> metadataP <* many eol<*> titleP - lineOffset = pred . sourceLine <$> getPosition - bodyP = lines <$> many anyChar <* eof - -metadataP :: Parser Metadata -metadataP = Map.fromList <$> option [] ( - metaSectionSeparator *> many eol *> - (try keyVal) `endBy` (many1 eol) - <* metaSectionSeparator - ) "metadata section" - where - metaSectionSeparator = count 3 (oneOf "~-") *> eol - spaces = skipMany $ char ' ' - keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n" - -titleP :: Parser String -titleP = try (singleLine <|> underlined) - where - singleLine = char '#' *> char ' ' *> no "\r\n" <* eol - underlined = - no "\r\n" <* eol - >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine - "'#' or '=' to underline the title" - -eol :: Parser String -eol = try (string "\r\n") <|> string "\r" <|> string "\n" "newline" - -no :: String -> Parser String -no = many1 . noneOf - setDate :: String -> CTime -> Metadata -> Metadata setDate tzOffset defaultDate = Map.alter timeStamp "date" where @@ -82,27 +30,16 @@ setDate tzOffset defaultDate = Map.alter timeStamp "date" let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in foldr (<|>) (timeStamp Nothing) (fmap epoch <$> parsedTimes) -makeArticle :: FilePath -> (Metadata -> Metadata) -> ProtoArticle -> (String, Article) -makeArticle filePath metaFilter (title, metadata, bodyOffset, body) = ( - getKey filePath - , Article { - key = getKey filePath - , title - , metadata = metaFilter metadata - , bodyOffset - , body - } - ) +makeArticle :: (Metadata -> Metadata) -> Markdown -> (String, Article) +makeArticle metaFilter markdown@(Markdown {key, metadata}) = + (key, Article $ markdown {metadata = metaFilter metadata}) at :: FilePath -> IO (Either ParseError (String, Article)) at filePath = do tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone fileDate <- modificationTime <$> getFileStatus filePath - let build = makeArticle filePath (setDate tzOffset fileDate) - fmap build . parse articleP filePath <$> readFile filePath + fmap (makeArticle (setDate tzOffset fileDate)) <$> Markdown.at filePath -getKey :: FilePath -> String -getKey = dropExtension . takeFileName - -preview :: Int -> Article -> Article -preview linesCount article = article {body = take linesCount $ body article} +preview :: Int -> Markdown -> Markdown +preview linesCount markdown@(Markdown {body}) = + markdown {body = take linesCount $ body} diff --git a/src/Blog.hs b/src/Blog.hs index 58ecd67..964791c 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -15,7 +15,7 @@ module Blog ( import Arguments (Arguments) import qualified Arguments (name, sourceDir) import Article (Article) -import qualified Article (at, getKey) +import qualified Article (at) import Blog.Path (Path(..)) import qualified Blog.Path as Path (build) import Blog.Template (Environment, Templates, render) @@ -36,6 +36,7 @@ import qualified Data.Set as Set (empty, null, singleton, union) import Data.Text (Text) import Files (File(..), absolute) import qualified Files (find) +import Markdown (getKey) import Page (Page) import qualified Page (at) import Prelude hiding (lookup) @@ -88,7 +89,7 @@ tagged collection path = do keys <- forM links $ \link -> do fileExists <- doesFileExist link return $ if fileExists - then let articleKey = Article.getKey link in + then let articleKey = getKey link in maybe Set.empty (\_ -> Set.singleton articleKey) (lookup articleKey collection) else Set.empty return (takeFileName path, foldl Set.union Set.empty keys) diff --git a/src/Collection.hs b/src/Collection.hs index 0a73798..360fde9 100644 --- a/src/Collection.hs +++ b/src/Collection.hs @@ -6,7 +6,7 @@ module Collection ( , title ) where -import Article(Article(metadata)) +import Article(Article(..)) import Blog (Blog(..), Path(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT, asks) @@ -15,6 +15,7 @@ import Data.Map ((!)) import qualified Data.Map as Map (elems, filterWithKey, toList) import Data.Ord (Down(..)) import qualified Data.Set as Set (member) +import Markdown (Markdown(metadata)) import Pretty ((.$)) import System.Directory (createDirectoryIfMissing) import System.FilePath (()) @@ -34,7 +35,7 @@ build featured tag = do featured = sortByDate featured, basePath, tag } where - sortByDate = sortOn (Down . (! "date") . metadata) + sortByDate = sortOn (Down . (! "date") . metadata . getMarkdown) getAll :: ReaderT Blog IO [Collection] getAll = do diff --git a/src/DOM/Card.hs b/src/DOM/Card.hs index 55334cc..4d9f837 100644 --- a/src/DOM/Card.hs +++ b/src/DOM/Card.hs @@ -2,12 +2,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module DOM.Card ( - Card(..) - , HasCard(..) + HasCard(..) , make ) where -import qualified Article (Article(..)) +import Article (Article(..)) import ArticlesList (ArticlesList(..)) import qualified ArticlesList (description) import Blog (Blog(..), Renderer, Skin(..)) @@ -19,18 +18,16 @@ import qualified Data.Map as Map (lookup) import Data.Text (Text, pack) import Lucid (HtmlT, content_, meta_) import Lucid.Base (makeAttribute) +import qualified Markdown (Markdown(..)) +import Page (Page(..)) import Pretty ((.$)) -data Card = Card { - cardType :: Text - , description :: Text - , image :: Maybe String - , title :: String - , urlPath :: String - } - class HasCard a where - getCard :: Renderer m => a -> m Card + cardType :: Renderer m => a -> m Text + description :: Renderer m => a -> m Text + image :: Renderer m => a -> m (Maybe String) + title :: Renderer m => a -> m String + urlPath :: Renderer m => a -> m String og :: Applicative m => Text -> Text -> HtmlT m () og attribute value = @@ -41,30 +38,49 @@ og attribute value = make :: (HasCard a, Renderer m) => a -> String -> HtmlT m () make element siteURL = do - Card {cardType, description, image, title, urlPath} <- getCard element - og "url" . pack $ siteURL ++ urlPath - og "type" cardType - og "title" $ pack title - og "description" description - maybeImage =<< ((image <|>) <$> (asks $skin.$cardImage)) + og "url" . sitePrefix =<< urlPath element + og "type" =<< cardType element + og "title" . pack =<< title element + og "description" =<< description element + maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage)) og "site_name" =<< (asks $name.$pack) where - maybeImage = maybe (return ()) (og "image" . pack . (siteURL++)) + maybeImage = maybe (return ()) (og "image" . sitePrefix) + sitePrefix = pack . (siteURL ++) -instance HasCard Article.Article where - getCard (Article.Article {Article.title, Article.metadata}) = do - description <- pack <$> getDescription (Map.lookup "summary" metadata) - return $ Card { - cardType = "article" - , description - , image = (Map.lookup "featuredImage" metadata) - , DOM.Card.title - , urlPath = "/articles/" ++ title ++ ".html" - } +instance HasCard Article where + cardType _ = return "article" + description (Article (Markdown.Markdown {Markdown.metadata})) = + fmap pack . getDescription $ Map.lookup "summary" metadata where getDescription = maybe (asks $name.$("A new article on " <>)) return + image (Article (Markdown.Markdown {Markdown.metadata})) = + return $ Map.lookup "featuredImage" metadata + title = return . Markdown.title . Article.getMarkdown + urlPath = fmap (\t -> "/articles/" ++ t ++ ".html") . title + +instance HasCard Page where + cardType _ = return "website" + description page@(Page (Markdown.Markdown {Markdown.metadata})) = + fmap pack . getDescription $ Map.lookup "summary" metadata + where + getDescription = maybe (title page) return + image (Page (Markdown.Markdown {Markdown.metadata})) = + return $ Map.lookup "featuredImage" metadata + title = return . Markdown.title . Page.getMarkdown + urlPath = fmap (\t -> "/pages/" ++ t ++ ".html") . title instance HasCard ArticlesList where + cardType _ = return "website" + description = ArticlesList.description + image _ = return Nothing + title (ArticlesList {collection}) = Collection.title collection + urlPath al@(ArticlesList {collection}) = + return $ maybe "" ('/':) (tag collection) ++ file + where + file = '/' : (if full al then "all" else "index") ++ ".html" + +{- getCard al@(ArticlesList {collection}) = do cardTitle <- Collection.title collection description <- ArticlesList.description al @@ -77,3 +93,4 @@ instance HasCard ArticlesList where } where file = '/' : (if full al then "all" else "index") ++ ".html" +-} diff --git a/src/JS.hs b/src/JS.hs index 46d7a1a..757142d 100644 --- a/src/JS.hs +++ b/src/JS.hs @@ -3,6 +3,8 @@ module JS ( generate ) where +import Data.Aeson (encode) + import Blog (Blog(..), Path(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (ReaderT, asks) @@ -31,7 +33,7 @@ var (varName, content) = concat ["\t", pack varName, " : ", content] generateConfig :: FilePath -> ReaderT Blog IO () generateConfig destinationDir = do - blogJSON <- exportBlog + blogJSON <- asks (encode . exportBlog) remarkablePath <- asks $path.$remarkableConfig liftIO $ do remarkableJSON <- maybe (return "{html: true}") readFile remarkablePath diff --git a/src/JSON.hs b/src/JSON.hs index 3562455..0341ca1 100644 --- a/src/JSON.hs +++ b/src/JSON.hs @@ -4,58 +4,65 @@ module JSON ( exportBlog ) where -import Article (Article) import qualified Article (Article(..)) import Blog (Blog, Path, Skin, URL, Wording) import qualified Blog (Blog(..)) -import Control.Monad.Reader (ReaderT, ask) -import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode) -import Data.ByteString.Lazy (ByteString) +import Data.Aeson (Options(..), ToJSON(..), genericToEncoding, defaultOptions) import Data.Map (Map, mapWithKey) import qualified Data.Map as Map (filter, keys) import qualified Data.Set as Set (elems, member) import GHC.Generics +import Markdown (Markdown) +import qualified Markdown (Markdown(..)) +import qualified Page (Page(..)) -data ArticleExport = ArticleExport { +data MarkdownExport = MarkdownExport { title :: String - , bodyOffset :: Int , metadata :: Map String String - , tagged :: [String] + , bodyOffset :: Int + , tagged :: Maybe [String] } deriving (Generic) -instance ToJSON ArticleExport where - toEncoding = genericToEncoding defaultOptions +instance ToJSON MarkdownExport where + toEncoding = genericToEncoding (defaultOptions {omitNothingFields = True}) -data BlogDB = BlogDB { - articles :: Map String ArticleExport +exportMarkdown :: Maybe [String] -> Markdown -> MarkdownExport +--exportMarkdown :: Blog -> String -> Markdown -> MarkdownExport +exportMarkdown tagged markdown = MarkdownExport { +--exportMarkdown blog key article = MarkdownExport { + title = Markdown.title markdown + , metadata = Markdown.metadata markdown + , bodyOffset = Markdown.bodyOffset markdown + , tagged + --, tagged = Map.keys . Map.filter (Set.member key) $ Blog.tags blog + } + +data BlogExport = BlogExport { + articles :: Map String MarkdownExport , hasRSS :: Bool , path :: Path + , pages :: Map String MarkdownExport , skin :: Skin , tags :: Map String [String] , urls :: URL , wording :: Wording } deriving (Generic) -instance ToJSON BlogDB where +instance ToJSON BlogExport where toEncoding = genericToEncoding defaultOptions -exportArticle :: Blog -> String -> Article -> ArticleExport -exportArticle blog key article = ArticleExport { - title = Article.title article - , bodyOffset = Article.bodyOffset article - , metadata = Article.metadata article - , tagged = Map.keys . Map.filter (Set.member key) $ Blog.tags blog +exportBlog :: Blog -> BlogExport +exportBlog blog = BlogExport { + articles = getArticles $ Article.getMarkdown <$> Blog.articles blog + , hasRSS = Blog.hasRSS blog + , pages = getPages $ Page.getMarkdown <$> Blog.pages blog + , path = Blog.path blog + , skin = Blog.skin blog + , tags = Set.elems <$> Blog.tags blog + , urls = Blog.urls blog + , wording = Blog.wording blog } - -exportBlog :: ReaderT Blog IO ByteString -exportBlog = do - blog <- ask - return . encode $ BlogDB { - articles = mapWithKey (exportArticle blog) $ Blog.articles blog - , hasRSS = Blog.hasRSS blog - , path = Blog.path blog - , skin = Blog.skin blog - , tags = Set.elems <$> Blog.tags blog - , urls = Blog.urls blog - , wording = Blog.wording blog - } + where + tag key = Just . Map.keys . Map.filter (Set.member key) $ Blog.tags blog + getArticles = mapWithKey (exportMarkdown . tag) + getPages = mapWithKey (\_-> exportMarkdown Nothing) diff --git a/src/Markdown.hs b/src/Markdown.hs new file mode 100644 index 0000000..20491d6 --- /dev/null +++ b/src/Markdown.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Markdown ( + Markdown(..) + , Metadata + , at + , getKey + , parser + ) where + +import Control.Applicative ((<|>)) +import Data.Map (Map) +import qualified Data.Map as Map (fromList) +import System.FilePath (dropExtension, takeFileName) +import Text.ParserCombinators.Parsec ( + ParseError, Parser + , () + , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf + , oneOf, option, parse, skipMany, sourceLine, string, try + ) + +type Metadata = Map String String +data Markdown = Markdown { + key :: String + , title :: String + , metadata :: Metadata + , bodyOffset :: Int + , body :: [String] + } + +parser :: String -> Parser Markdown +parser key = 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} + where + headerP = (,) <$> titleP <* many eol <*> metadataP + reverseHeaderP = flip (,) <$> metadataP <* many eol<*> titleP + +metadataP :: Parser Metadata +metadataP = Map.fromList <$> option [] ( + metaSectionSeparator *> many eol *> + (try keyVal) `endBy` (many1 eol) + <* metaSectionSeparator + ) "metadata section" + where + metaSectionSeparator = count 3 (oneOf "~-") *> eol + spaces = skipMany $ char ' ' + keyVal = (,) <$> (no ": \r\n" <* spaces <* char ':' <* spaces) <*> no "\r\n" + +titleP :: Parser String +titleP = try (singleLine <|> underlined) + where + singleLine = char '#' *> char ' ' *> no "\r\n" <* eol + underlined = + no "\r\n" <* eol + >>= \titleLine -> count (length titleLine) (oneOf "#=") *> eol *> return titleLine + "'#' or '=' to underline the title" + +eol :: Parser String +eol = try (string "\r\n") <|> string "\r" <|> string "\n" "newline" + +no :: String -> Parser String +no = many1 . noneOf + +getKey :: FilePath -> String +getKey = dropExtension . takeFileName + +at :: FilePath -> IO (Either ParseError Markdown) +at filePath = parse (parser (getKey filePath)) filePath <$> readFile filePath diff --git a/src/Page.hs b/src/Page.hs index 6e74c5a..1bd5d5f 100644 --- a/src/Page.hs +++ b/src/Page.hs @@ -3,11 +3,15 @@ module Page ( , at ) where +import Markdown (Markdown(..)) +import qualified Markdown as Markdown (at) import Text.ParserCombinators.Parsec (ParseError) -data Page = Page { - title :: String +newtype Page = Page { + getMarkdown :: Markdown } at :: FilePath -> IO (Either ParseError (String, Page)) -at = undefined +at filePath = fmap makePage <$> Markdown.at filePath + where + makePage markdown = (key markdown, Page markdown)