From 3130f5ee848b3b2456517a61994b7dfacd510588 Mon Sep 17 00:00:00 2001 From: Tissevert Date: Fri, 15 Feb 2019 14:16:21 +0100 Subject: [PATCH] Use articles file names as hash keys and set date as a metadata --- hablo.cabal | 1 + src/Article.hs | 73 +++++++++++++++++++++++++++++++++++--------------- src/Blog.hs | 25 ++++++++--------- src/HTML.hs | 4 +-- src/JSON.hs | 29 ++++++++------------ 5 files changed, 77 insertions(+), 55 deletions(-) diff --git a/hablo.cabal b/hablo.cabal index d991775..5019304 100644 --- a/hablo.cabal +++ b/hablo.cabal @@ -44,6 +44,7 @@ executable hablo , optparse-applicative , parsec , text + , time , unix ghc-options: -Wall hs-source-dirs: src diff --git a/src/Article.hs b/src/Article.hs index dad92ff..d8d9fe7 100644 --- a/src/Article.hs +++ b/src/Article.hs @@ -3,39 +3,48 @@ module Article ( Article(..) , at + , key , preview , titleP ) where +import Control.Applicative ((<|>)) import Data.Map (Map) -import qualified Data.Map as Map (fromList) -import System.FilePath (dropExtension) -import System.Posix.Types (FileID) -import System.Posix.Files (FileStatus, getFileStatus, fileID) +import qualified Data.Map as Map (fromList, 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 System.Posix.Files (getFileStatus, modificationTime) import Text.ParserCombinators.Parsec ( ParseError , Parser - , (<|>) - , anyChar, char, count, endBy, eof, many, many1, noneOf, oneOf, option, parse, skipMany, spaces, string, try +-- , (<|>) + , anyChar, char, count, endBy, eof, getPosition, many, many1, noneOf + , oneOf, option, parse, skipMany, sourceLine, spaces, string, try ) +type Metadata = Map String String + data Article = Article { - urlPath :: String - , fileStatus :: FileStatus + urlPath :: FilePath , title :: String - , metadata :: Map String String + , metadata :: Metadata + , bodyOffset :: Int , body :: [String] } -articleP :: Parser (String, Map String String, [String]) +articleP :: Parser (String, Metadata, Int, [String]) articleP = - skipMany eol *> headerP <* skipMany eol <*> (lines <$> many anyChar <* eof) + skipMany eol *> headerP <* skipMany eol <*> lineOffset <*> bodyP where headerP = - try ((,,) <$> titleP <* many eol <*> metadataP) - <|> flip (,,) <$> metadataP <* many eol<*> titleP + try ((,,,) <$> titleP <* many eol <*> metadataP) + <|> flip (,,,) <$> metadataP <* many eol<*> titleP + lineOffset = sourceLine <$> getPosition + bodyP = lines <$> many anyChar <* eof -metadataP :: Parser (Map String String) +metadataP :: Parser Metadata metadataP = Map.fromList <$> option [] ( metaSectionSeparator *> many eol *> (try keyVal) `endBy` (many1 eol) @@ -59,15 +68,37 @@ eol = try (string "\r\n") <|> string "\r" <|> string "\n" no :: String -> Parser String no = many1 . noneOf -at :: FilePath -> IO (Either ParseError (FileID, Article)) -at filePath = do - fileStatus <- getFileStatus filePath - fmap (makeArticle fileStatus) . parse articleP filePath <$> readFile filePath +setDate :: String -> CTime -> Metadata -> Metadata +setDate tzOffset defaultDate = Map.alter timeStamp "date" where - makeArticle fileStatus (title, metadata, body) = ( - fileID fileStatus - , Article {urlPath = dropExtension filePath, fileStatus, title, body, metadata} + formats = ("%Y-%m-%d" ++) . (++ " %z") <$> ["", " %H:%M"] + epoch = show . (truncate :: POSIXTime -> Integer) . utcTimeToPOSIXSeconds + timeStamp Nothing = Just $ show defaultDate + timeStamp (Just date) = + let dates = [date, date ++ " " ++ tzOffset] in + let parsedTimes = parseTimeM True defaultTimeLocale <$> formats <*> dates in + foldr (<|>) (timeStamp Nothing) (fmap epoch <$> parsedTimes) + +at :: FilePath -> IO (Either ParseError (String, Article)) +at filePath = do + tzOffset <- timeZoneOffsetString <$> getCurrentTimeZone + fileDate <- modificationTime <$> getFileStatus filePath + let build = makeArticle (setDate tzOffset fileDate) + fmap build . parse articleP filePath <$> readFile filePath + where + makeArticle metaFilter (title, metadata, bodyOffset, body) = ( + key filePath + , Article { + urlPath = dropExtension filePath + , title + , metadata = metaFilter metadata + , bodyOffset + , body + } ) +key :: FilePath -> String +key = dropExtension . takeFileName + preview :: Int -> Article -> Article preview linesCount article = article {body = take linesCount $ body article} diff --git a/src/Blog.hs b/src/Blog.hs index 9a4f3fa..e3c4832 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -10,7 +10,7 @@ module Blog ( import Arguments (Arguments(sourceDir)) import qualified Arguments (name) import Article (Article) -import qualified Article (at) +import qualified Article (at, key) import Blog.Skin (Skin(..)) import qualified Blog.Skin as Skin (build) import Control.Monad ((>=>), filterM, forM) @@ -23,23 +23,21 @@ import qualified Data.Set as Set (empty, null, singleton, union) import qualified Files (find) import System.Directory (doesFileExist, withCurrentDirectory) import System.FilePath ((), dropTrailingPathSeparator, splitFileName, takeExtension, takeFileName) -import System.Posix.Types (FileID) -import System.Posix.Files (getFileStatus, fileID) -type Collection = Map FileID Article +type Collection = Map String Article data Blog = Blog { articles :: Collection , name :: String , root :: FilePath , skin :: Skin - , tags :: Map String (Set FileID) + , tags :: Map String (Set String) } get :: MonadReader Blog m => (Blog -> a) -> m a get = (<$> ask) -findArticles :: FilePath -> IO (Map FileID Article) +findArticles :: FilePath -> IO (Map String Article) findArticles = Files.find >=> filterM isMarkDownFile @@ -50,17 +48,16 @@ findArticles = let correctExtension = takeExtension path == ".md" (correctExtension &&) <$> doesFileExist path -tagged :: Collection -> FilePath -> IO (String, Set FileID) +tagged :: Collection -> FilePath -> IO (String, Set String) tagged collection path = do links <- Files.find path - fileIDs <- forM links $ \link -> do + keys <- forM links $ \link -> do fileExists <- doesFileExist link - if fileExists - then do - inode <- fileID <$> getFileStatus link - return $ if Map.member inode collection then Set.singleton inode else Set.empty - else return Set.empty - return (takeFileName path, foldl Set.union Set.empty fileIDs) + return $ if fileExists + then let articleKey = Article.key link in + if Map.member articleKey collection then Set.singleton articleKey else Set.empty + else Set.empty + return (takeFileName path, foldl Set.union Set.empty keys) build :: Arguments -> IO Blog build arguments = withCurrentDirectory root $ do diff --git a/src/HTML.hs b/src/HTML.hs index ea4d5d8..9b8f1ee 100644 --- a/src/HTML.hs +++ b/src/HTML.hs @@ -12,6 +12,7 @@ import Control.Monad (forM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..), ReaderT) import Data.List (sortOn) +import Data.Map ((!)) import qualified Data.Map as Map (elems, filterWithKey, toList) import Data.Ord (Down(..)) import qualified Data.Set as Set (member) @@ -21,7 +22,6 @@ import Lucid import Pretty ((.$)) import System.Directory (createDirectoryIfMissing) import System.FilePath.Posix ((), (<.>)) -import System.Posix.Files (modificationTime) data Collection = Collection { articlesFeatured :: [Article] @@ -38,7 +38,7 @@ collection articlesFeatured tag = do , tag } where - sortByDate = sortOn (Down . modificationTime . fileStatus) + sortByDate = sortOn (Down . (! "date") . metadata) articlesLists :: Monad m => Collection -> ReaderT Blog m [(FilePath, ArticlesList)] articlesLists (Collection {articlesFeatured, basePath, tag}) = do diff --git a/src/JSON.hs b/src/JSON.hs index a73dd0f..9332474 100644 --- a/src/JSON.hs +++ b/src/JSON.hs @@ -11,19 +11,16 @@ import qualified Blog (Blog(..), Skin(..)) import Control.Monad.Reader (ReaderT, ask) import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode) import Data.ByteString.Lazy (ByteString) -import Data.Map (Map, (!), foldlWithKey, mapKeys, mapWithKey) -import qualified Data.Map as Map (empty, filter, insert, keys) +import Data.Map (Map, mapWithKey) +import qualified Data.Map as Map (filter, keys) import qualified Data.Set as Set (elems, member) import System.FilePath.Posix ((), (<.>)) -import System.Posix.Files (modificationTime) -import System.Posix.Types (EpochTime, FileID) import GHC.Generics -type ArticleID = Int - data ArticleExport = ArticleExport { source :: String , title :: String + , bodyOffset :: Int , metadata :: Map String String , tagged :: [String] } deriving (Generic) @@ -40,33 +37,29 @@ instance ToJSON SkinExport where toEncoding = genericToEncoding defaultOptions data BlogDB = BlogDB { - articles :: Map ArticleID ArticleExport - , tags :: Map String [ArticleID] + articles :: Map String ArticleExport + , tags :: Map String [String] , skin :: SkinExport } deriving (Generic) instance ToJSON BlogDB where toEncoding = genericToEncoding defaultOptions -remap :: (Ord k1, Enum k2, Ord k2) => Map k1 a -> Map k1 k2 -remap = - snd . foldlWithKey (\(i, tempMap) key _ -> (succ i, Map.insert key i tempMap)) (toEnum 0, Map.empty) - -export :: Blog -> FileID -> Article -> ArticleExport -export blog fileID article = ArticleExport { +export :: Blog -> String -> Article -> ArticleExport +export blog key article = ArticleExport { source = "/" Article.urlPath article <.> "md" , title = Article.title article + , bodyOffset = Article.bodyOffset article , metadata = Article.metadata article - , tagged = Map.keys . Map.filter (Set.member fileID) $ Blog.tags blog + , tagged = Map.keys . Map.filter (Set.member key) $ Blog.tags blog } exportBlog :: ReaderT Blog IO ByteString exportBlog = do blog <- ask - let reindex = remap $ Blog.articles blog return . encode $ BlogDB { - articles = mapKeys (reindex !) $ mapWithKey (export blog) (Blog.articles blog) - , tags = fmap (reindex !) . Set.elems <$> Blog.tags blog + articles = mapWithKey (export blog) $ Blog.articles blog + , tags = Set.elems <$> Blog.tags blog , skin = SkinExport { previewArticlesCount = Blog.previewArticlesCount $ Blog.skin blog , previewLinesCount = Blog.previewLinesCount $ Blog.skin blog