diff --git a/app/Main.hs b/app/Main.hs index 2ab6d81..dd61978 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -21,7 +21,8 @@ import Development.Shake.FilePath (()) import qualified Development.Shake.FilePath as FP import Templates import Types -import Utilities +import Utilities.Action (getPublishedPosts, isDraft', markdownToHtml, markdownToPost, now) +import Utilities.FilePath (indexHtmlOutputPath, indexHtmlSourcePaths, isMarkdownPost, urlConvert) -- target = thing we want -- Rule = pattern of thing being made + actions to produce the thing @@ -47,7 +48,7 @@ buildSite = do Shake.need $ map indexHtmlOutputPath pagePaths -- handle posts - postPaths <- getPublishedPosts + postPaths <- getPublishedPosts isDraft Shake.need $ map indexHtmlOutputPath postPaths -- remaining pages, index.xml = rss feed @@ -95,7 +96,7 @@ markdownPost src = do let rPost = fromPost post postHtml <- applyTemplate "post.html" rPost - time <- Utilities.now + time <- Utilities.Action.now -- Shake.putInfo $ T.unpack $ urlConvert target let page = Page @@ -111,13 +112,13 @@ markdownPost src = do home :: Rules () home = outputDir "index.html" %> \target -> do - postPaths <- getPublishedPosts + postPaths <- getPublishedPosts isDraft posts <- sortOn (Ord.Down . postDate) <$> forM postPaths readPost let posts' = map fromPost posts html <- applyTemplate "home.html" $ HM.singleton "posts" posts' - time <- Utilities.now + time <- Utilities.Action.now -- Shake.putInfo $ T.unpack $ urlConvert target let page = Page @@ -140,9 +141,9 @@ data Rss = Rss rss :: Rules () rss = outputDir "index.xml" %> \target -> do - postPaths <- getPublishedPosts + postPaths <- getPublishedPosts isDraft posts <- map fromPost . sortOn (Ord.Down . postDate) <$> forM postPaths readPost - time <- Utilities.now + time <- Utilities.Action.now applyTemplateAndWrite "feed.xml" (Rss time posts) target -- Shake.putInfo $ "Built " <> target @@ -161,3 +162,9 @@ readMarkdownPost postPath = do { postContent = Just html, postLink = Just . T.pack $ "/" <> FP.dropExtension postPath <> "/" } + +postHandles :: [(FilePath -> Bool, FilePath -> Action Post)] +postHandles = [(isMarkdownPost, markdownToPost)] + +isDraft :: FilePath -> Action Bool +isDraft = isDraft' postHandles diff --git a/app/Markdown.hs b/app/Markdown.hs index 3c8edfb..ac2391b 100644 --- a/app/Markdown.hs +++ b/app/Markdown.hs @@ -17,16 +17,14 @@ import Logger (Logger (logDebug)) import Text.Megaparsec (ParsecT, anySingle, anySingleBut, between, choice, count, eof, manyTill, notFollowedBy, satisfy, skipSome, try, ()) import qualified Text.Megaparsec as MP import Text.Megaparsec.Char (alphaNumChar, char, digitChar, string) +import Utilities (tee) type ParserT m = ParsecT Void String m type Parser = ParserT Identity logP :: (Logger m, Show s) => ParserT m s -> ParserT m s -logP v = do - underlying <- v - logDebug $ T.show underlying - v +logP = tee (logDebug . T.show) anyChar :: ParserT m Char anyChar = anySingle diff --git a/app/Utilities.hs b/app/Utilities.hs index 2483850..c867a8a 100644 --- a/app/Utilities.hs +++ b/app/Utilities.hs @@ -1,101 +1,14 @@ module Utilities where -import Config -import Control.Monad (filterM) -import Data.Functor.Identity (Identity (runIdentity)) -import Data.List (find) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Data.Time -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.Yaml.Aeson -import Development.Shake (Action) -import qualified Development.Shake as Shake -import Development.Shake.FilePath ((<.>), ()) -import qualified Development.Shake.FilePath as FP -import HTML -import Markdown -import Text.Megaparsec (errorBundlePretty, runParserT) -import Types - -indexHtmlOutputPath :: FilePath -> FilePath -indexHtmlOutputPath srcPath = - outputDir FP.dropExtension srcPath "index.html" - --- were applicative shenanigans necessary? no --- but using them felt cool -indexHtmlSourcePaths :: FilePath -> [FilePath] -indexHtmlSourcePaths path = [indexHtmlMarkdownSourcePath] <*> [path] - -indexHtmlMarkdownSourcePath :: FilePath -> FilePath -indexHtmlMarkdownSourcePath = - FP.dropDirectory1 - . (<.> "md") - . FP.dropTrailingPathSeparator - . FP.dropFileName - -markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text) -markdownToHtml filePath = do - content <- Shake.readFile' filePath - let parse = runIdentity $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath content - let (metadataText, document) = case parse of - Right (a, b) -> (a, b) - Left e -> error $ errorBundlePretty e - - let metadata = case decodeEither' $ encodeUtf8 metadataText of - Right m -> m - Left e -> error $ show e - pure (metadata, compileToHTML document) - -now :: Action T.Text -now = Shake.liftIO $ fmap (T.pack . iso8601Show) getCurrentTime - -markdownToPost :: FilePath -> Action Post -markdownToPost path = do - content <- Shake.readFile' path - let parse = runIdentity $ runParserT Markdown.metadata path content - let postData = case parse of - Right p -> p - Left e -> error $ errorBundlePretty e - let post = case decodeEither' $ encodeUtf8 postData of - Right p -> p - Left e -> error $ show e - pure post - -yamlToPost :: FilePath -> Action Post -yamlToPost path = do - post <- decodeFileThrow path - -- let post' = dateTransform post - return post - -isMarkdownPost :: FilePath -> Bool -isMarkdownPost path = FP.takeExtension path == ".md" - -postHandles :: [(FilePath -> Bool, FilePath -> Action Post)] -postHandles = [(isMarkdownPost, markdownToPost)] - -isDraft :: FilePath -> Action Bool -isDraft path = do - let action = - case find (\(test, _) -> test path) postHandles of - (Just (_, action')) -> action' - Nothing -> error "no post handle for this file type" - post <- action path - return $ case postDraft post of - Just ret -> ret - Nothing -> (error $ "Missing draft attr: " ++ path) - -getPublishedPosts :: Action [FilePath] -getPublishedPosts = do - postPaths <- Shake.getDirectoryFiles "" postGlobs - filterM (fmap not . isDraft) postPaths parseDate :: Text -> Maybe Text parseDate str = do date <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d" $ T.unpack str -- need to append the time to avoid potential issues - return $ T.pack $ formatTime @UTCTime defaultTimeLocale "%Y-%m-%dT00:00:00Z" date + pure $ T.pack $ formatTime @UTCTime defaultTimeLocale "%Y-%m-%dT00:00:00Z" date -urlConvert :: FilePath -> Text -urlConvert = T.pack . FP.dropFileName . flip FP.replaceDirectory1 "https://pagwin.xyz" +tee :: (Monad m) => (a -> m b) -> m a -> m a +tee f v = v >>= (\underlying -> f underlying *> v) diff --git a/app/Utilities/Action.hs b/app/Utilities/Action.hs new file mode 100644 index 0000000..57c2d42 --- /dev/null +++ b/app/Utilities/Action.hs @@ -0,0 +1,62 @@ +module Utilities.Action where + +import Config (postGlobs) +import Control.Monad (filterM) +import Data.Functor.Identity (Identity (runIdentity)) +import Data.List (find) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.Yaml.Aeson +import Development.Shake (Action) +import qualified Development.Shake as Shake +import HTML +import Markdown +import Text.Megaparsec (errorBundlePretty, runParserT) +import Types + +markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text) +markdownToHtml filePath = do + content <- Shake.readFile' filePath + let parse = runIdentity $ runParserT (liftA2 (,) Markdown.metadata Markdown.document) filePath content + let (metadataText, document) = case parse of + Right (a, b) -> (a, b) + Left e -> error $ errorBundlePretty e + + let metadata = case decodeEither' $ encodeUtf8 metadataText of + Right m -> m + Left e -> error $ show e + pure (metadata, compileToHTML document) + +markdownToPost :: FilePath -> Action Post +markdownToPost path = do + content <- Shake.readFile' path + let parse = runIdentity $ runParserT Markdown.metadata path content + let postData = case parse of + Right p -> p + Left e -> error $ errorBundlePretty e + let post = case decodeEither' $ encodeUtf8 postData of + Right p -> p + Left e -> error $ show e + pure post + +now :: Action T.Text +now = Shake.liftIO $ fmap (T.pack . iso8601Show) getCurrentTime + +isDraft' :: [(FilePath -> Bool, FilePath -> Action Post)] -> FilePath -> Action Bool +isDraft' postHandles path = do + let action = + case find (\(test, _) -> test path) postHandles of + (Just (_, action')) -> action' + Nothing -> error "no post handle for this file type" + post <- action path + pure $ case postDraft post of + Just ret -> ret + Nothing -> (error $ "Missing draft attr: " ++ path) + +getPublishedPosts :: (FilePath -> Action Bool) -> Action [FilePath] +getPublishedPosts draftCheck = do + postPaths <- Shake.getDirectoryFiles "" postGlobs + filterM (fmap not . draftCheck) postPaths diff --git a/app/Utilities/FilePath.hs b/app/Utilities/FilePath.hs new file mode 100644 index 0000000..2626687 --- /dev/null +++ b/app/Utilities/FilePath.hs @@ -0,0 +1,27 @@ +module Utilities.FilePath where + +import Config +import Data.Text (Text) +import qualified Data.Text as T +import Development.Shake.FilePath ((<.>), ()) +import qualified Development.Shake.FilePath as FP + +indexHtmlOutputPath :: FilePath -> FilePath +indexHtmlOutputPath srcPath = + outputDir FP.dropExtension srcPath "index.html" + +indexHtmlSourcePaths :: FilePath -> [FilePath] +indexHtmlSourcePaths path = map ($ path) [indexHtmlMarkdownSourcePath] + +indexHtmlMarkdownSourcePath :: FilePath -> FilePath +indexHtmlMarkdownSourcePath = + FP.dropDirectory1 + . (<.> "md") + . FP.dropTrailingPathSeparator + . FP.dropFileName + +isMarkdownPost :: FilePath -> Bool +isMarkdownPost path = FP.takeExtension path == ".md" + +urlConvert :: FilePath -> Text +urlConvert = T.pack . FP.dropFileName . flip FP.replaceDirectory1 "https://pagwin.xyz" diff --git a/psb.cabal b/psb.cabal index aa287d2..ee42afa 100644 --- a/psb.cabal +++ b/psb.cabal @@ -29,7 +29,7 @@ executable psb -- .hs or .lhs file containing the Main module. main-is: Main.hs - other-modules: Config Utilities Templates Types IR Markdown Restruct HTML Logger + other-modules: Config Utilities Utilities.FilePath Utilities.Action Templates Types IR Markdown Restruct HTML Logger default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric OverloadedRecordDot NamedFieldPuns DuplicateRecordFields DisambiguateRecordFields FlexibleInstances