diff --git a/hakyll-blog.cabal b/hakysidian.cabal similarity index 76% rename from hakyll-blog.cabal rename to hakysidian.cabal index 87b2bb9..a25232c 100644 --- a/hakyll-blog.cabal +++ b/hakysidian.cabal @@ -1,13 +1,20 @@ -name: hakyll-blog +name: hakysidian version: 0.1.0.0 build-type: Simple -cabal-version: >= 1.10 +cabal-version: 2.0 +data-files: + templates/*.html + css/*.css + fonts/*.woff2 + bib_style.csl + favicon.ico executable site hs-source-dirs: src main-is: site.hs - other-modules: ChaoDoc, SideNoteHTML, Pangu + autogen-modules: Paths_hakysidian + other-modules: ChaoDoc, SideNoteHTML, Pangu, Paths_hakysidian build-depends: base >= 4.18 , hakyll >= 4.15 , mtl >= 2.2.2 @@ -17,10 +24,12 @@ executable site , tagsoup , text , containers + , directory -- , process -- , regex-compat , array , filepath + , temporary -- , ghc-syntax-highlighter -- , blaze-html >= 0.9 , megaparsec @@ -34,4 +43,4 @@ executable site -Wno-unsafe -Wno-prepositive-qualified-module -O2 -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 \ No newline at end of file + default-language: Haskell2010 diff --git a/src/site.hs b/src/site.hs index 214b994..3d693bc 100644 --- a/src/site.hs +++ b/src/site.hs @@ -2,13 +2,32 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE ViewPatterns #-} import ChaoDoc -import Data.List (sortOn) +import Control.Monad (filterM, forM_, unless) +import Data.Kind (Type) +import Data.List (sortOn, stripPrefix) import qualified Data.Text as T import Hakyll +import qualified Paths_hakysidian as Paths +import System.Directory + ( copyFile, + createDirectoryIfMissing, + createDirectoryLink, + createFileLink, + doesDirectoryExist, + doesFileExist, + listDirectory, + makeAbsolute, + withCurrentDirectory + ) +import System.Environment (getArgs, withArgs) +import System.Exit (die, exitSuccess) import System.FilePath +import System.IO.Error (tryIOError) +import System.IO.Temp (withSystemTempDirectory) import Text.Pandoc -------------------------------------------------------------------------------- @@ -16,40 +35,371 @@ import Text.Pandoc cleanRoute :: Routes cleanRoute = customRoute createIndexRoute where - createIndexRoute ident = takeDirectory p takeBaseName p "index.html" + createIndexRoute :: Identifier -> FilePath + createIndexRoute ident + | dir == "." = base "index.html" + | otherwise = dir base "index.html" where p = toFilePath ident + dir = takeDirectory p + base = takeBaseName p cleanIndexHtmls :: Item String -> Compiler (Item String) cleanIndexHtmls = return . fmap (replaceAll pattern replacement) where - pattern :: String = "/index.html" - replacement :: String -> String = const "/" + pattern :: String + pattern = "/index.html" + + replacement :: String -> String + replacement = const "/" + +notePattern :: Pattern +notePattern = + fromGlob "*.md" + .&&. complement (fromGlob "math-macros.md") + .&&. complement (fromGlob "index.md") + +reservedMarkdownFiles :: [FilePath] +reservedMarkdownFiles = ["index.md", "math-macros.md"] loadNoteLinks :: Compiler [Item String] loadNoteLinks = do - noteIds <- sortOn toFilePath <$> getMatches "notes/*" + noteIds <- sortOn toFilePath <$> getMatches notePattern pure [Item noteId "" | noteId <- noteIds] -------------------------------------------------------------------------------- -config :: Configuration -config = +type CliOptions :: Type +data CliOptions = CliOptions + { cliContentDir :: Maybe FilePath, + cliOutputDir :: Maybe FilePath, + cliReferenceBib :: Maybe FilePath, + cliMathMacros :: Maybe FilePath, + cliCssDir :: Maybe FilePath, + cliFontsDir :: Maybe FilePath, + cliTemplatesDir :: Maybe FilePath, + cliBibStyle :: Maybe FilePath, + cliFavicon :: Maybe FilePath + } + +type ResolvedOptions :: Type +data ResolvedOptions = ResolvedOptions + { resolvedContentDir :: FilePath, + resolvedOutputDir :: FilePath, + resolvedStoreDir :: FilePath, + resolvedTmpDir :: FilePath, + resolvedReferenceBib :: FilePath, + resolvedMathMacros :: FilePath, + resolvedImagesDir :: Maybe FilePath, + resolvedCssDir :: FilePath, + resolvedFontsDir :: FilePath, + resolvedTemplatesDir :: FilePath, + resolvedBibStyle :: FilePath, + resolvedFavicon :: FilePath + } + +type ParseResult :: Type +data ParseResult + = Parsed CliOptions [String] + | ShowHelp + +defaultCliOptions :: CliOptions +defaultCliOptions = + CliOptions + { cliContentDir = Nothing, + cliOutputDir = Nothing, + cliReferenceBib = Nothing, + cliMathMacros = Nothing, + cliCssDir = Nothing, + cliFontsDir = Nothing, + cliTemplatesDir = Nothing, + cliBibStyle = Nothing, + cliFavicon = Nothing + } + +helpText :: String +helpText = + unlines + [ "Hakysidian", + "", + "Usage:", + " site [options] [build|watch|clean|rebuild|preview ...]", + "", + "The content directory should contain top-level markdown files,", + "an optional images/ folder, plus reference.bib and math-macros.md.", + "", + "Options:", + " --content-dir PATH Folder containing markdown files.", + " --output-dir PATH Destination for generated HTML. Default: CONTENT/_site", + " --reference-bib PATH Bibliography file. Default: CONTENT/reference.bib", + " --math-macros PATH Math macros file. Default: CONTENT/math-macros.md", + " --css-dir PATH Shared CSS directory. Default: packaged asset directory", + " --fonts-dir PATH Shared fonts directory. Default: packaged asset directory", + " --templates-dir PATH Shared templates directory. Default: packaged asset directory", + " --bib-style PATH CSL file. Default: packaged bib_style.csl", + " --favicon PATH Favicon file. Default: packaged favicon.ico", + " --help Show this help text" + ] + +parseCliArgs :: [String] -> Either String ParseResult +parseCliArgs = go defaultCliOptions [] + where + go :: CliOptions -> [String] -> [String] -> Either String ParseResult + go options passthrough = \case + [] -> Right (Parsed options (reverse passthrough)) + "--" : rest -> Right (Parsed options (reverse passthrough ++ rest)) + "--help" : _ -> Right ShowHelp + "-h" : _ -> Right ShowHelp + arg : rest + | Just value <- stripPrefix "--content-dir=" arg -> + go options {cliContentDir = Just value} passthrough rest + | Just value <- stripPrefix "--output-dir=" arg -> + go options {cliOutputDir = Just value} passthrough rest + | Just value <- stripPrefix "--reference-bib=" arg -> + go options {cliReferenceBib = Just value} passthrough rest + | Just value <- stripPrefix "--ref=" arg -> + go options {cliReferenceBib = Just value} passthrough rest + | Just value <- stripPrefix "--math-macros=" arg -> + go options {cliMathMacros = Just value} passthrough rest + | Just value <- stripPrefix "--css-dir=" arg -> + go options {cliCssDir = Just value} passthrough rest + | Just value <- stripPrefix "--fonts-dir=" arg -> + go options {cliFontsDir = Just value} passthrough rest + | Just value <- stripPrefix "--templates-dir=" arg -> + go options {cliTemplatesDir = Just value} passthrough rest + | Just value <- stripPrefix "--bib-style=" arg -> + go options {cliBibStyle = Just value} passthrough rest + | Just value <- stripPrefix "--favicon=" arg -> + go options {cliFavicon = Just value} passthrough rest + | arg == "--content-dir" -> + setPathOption "--content-dir" cliContentDir (\x y -> x {cliContentDir = Just y}) options passthrough rest + | arg == "--output-dir" -> + setPathOption "--output-dir" cliOutputDir (\x y -> x {cliOutputDir = Just y}) options passthrough rest + | arg == "--reference-bib" -> + setPathOption "--reference-bib" cliReferenceBib (\x y -> x {cliReferenceBib = Just y}) options passthrough rest + | arg == "--ref" -> + setPathOption "--ref" cliReferenceBib (\x y -> x {cliReferenceBib = Just y}) options passthrough rest + | arg == "--math-macros" -> + setPathOption "--math-macros" cliMathMacros (\x y -> x {cliMathMacros = Just y}) options passthrough rest + | arg == "--css-dir" -> + setPathOption "--css-dir" cliCssDir (\x y -> x {cliCssDir = Just y}) options passthrough rest + | arg == "--fonts-dir" -> + setPathOption "--fonts-dir" cliFontsDir (\x y -> x {cliFontsDir = Just y}) options passthrough rest + | arg == "--templates-dir" -> + setPathOption "--templates-dir" cliTemplatesDir (\x y -> x {cliTemplatesDir = Just y}) options passthrough rest + | arg == "--bib-style" -> + setPathOption "--bib-style" cliBibStyle (\x y -> x {cliBibStyle = Just y}) options passthrough rest + | arg == "--favicon" -> + setPathOption "--favicon" cliFavicon (\x y -> x {cliFavicon = Just y}) options passthrough rest + | otherwise -> + go options (arg : passthrough) rest + + setPathOption :: + String -> + (CliOptions -> Maybe FilePath) -> + (CliOptions -> FilePath -> CliOptions) -> + CliOptions -> + [String] -> + [String] -> + Either String ParseResult + setPathOption optionName getter setter options passthrough = \case + [] -> Left ("Missing value for " ++ optionName) + value : rest + | null value -> Left ("Missing value for " ++ optionName) + | getter options == Nothing -> + go (setter options value) passthrough rest + | otherwise -> + go (setter options value) passthrough rest + +resolveCliOptions :: CliOptions -> IO ResolvedOptions +resolveCliOptions options = do + contentDir <- makeAbsolute (maybe "." id (cliContentDir options)) + validateDirectoryExists "content directory" contentDir + + let outputDir0 = maybe (contentDir "_site") id (cliOutputDir options) + referenceBib0 = maybe (contentDir "reference.bib") id (cliReferenceBib options) + mathMacros0 = maybe (contentDir "math-macros.md") id (cliMathMacros options) + storeDir0 = contentDir ".hakysidian-cache" + tmpDir0 = contentDir ".hakysidian-tmp" + + outputDir <- makeAbsolute outputDir0 + referenceBib <- makeAbsolute referenceBib0 + mathMacros <- makeAbsolute mathMacros0 + storeDir <- makeAbsolute storeDir0 + tmpDir <- makeAbsolute tmpDir0 + + validateFileExists "reference bibliography" referenceBib + validateFileExists "math macros" mathMacros + + imagesDir <- resolveOptionalDirectory (contentDir "images") + cssDir <- resolveDirectoryOption "css directory" (cliCssDir options) defaultCssDir + fontsDir <- resolveDirectoryOption "fonts directory" (cliFontsDir options) defaultFontsDir + templatesDir <- resolveDirectoryOption "templates directory" (cliTemplatesDir options) defaultTemplatesDir + bibStyle <- resolveFileOption "CSL file" (cliBibStyle options) defaultBibStyle + favicon <- resolveFileOption "favicon" (cliFavicon options) defaultFavicon + + pure + ResolvedOptions + { resolvedContentDir = contentDir, + resolvedOutputDir = outputDir, + resolvedStoreDir = storeDir, + resolvedTmpDir = tmpDir, + resolvedReferenceBib = referenceBib, + resolvedMathMacros = mathMacros, + resolvedImagesDir = imagesDir, + resolvedCssDir = cssDir, + resolvedFontsDir = fontsDir, + resolvedTemplatesDir = templatesDir, + resolvedBibStyle = bibStyle, + resolvedFavicon = favicon + } + +defaultCssDir :: IO FilePath +defaultCssDir = takeDirectory <$> resolvePackagedFile ("css" "default.css") + +defaultFontsDir :: IO FilePath +defaultFontsDir = takeDirectory <$> resolvePackagedFile ("fonts" "IosevkaCustom-Regular.woff2") + +defaultTemplatesDir :: IO FilePath +defaultTemplatesDir = takeDirectory <$> resolvePackagedFile ("templates" "head.html") + +defaultBibStyle :: IO FilePath +defaultBibStyle = resolvePackagedFile "bib_style.csl" + +defaultFavicon :: IO FilePath +defaultFavicon = resolvePackagedFile "favicon.ico" + +resolvePackagedFile :: FilePath -> IO FilePath +resolvePackagedFile relativePath = do + installedPath <- Paths.getDataFileName relativePath + installedExists <- doesFileExist installedPath + if installedExists + then pure installedPath + else makeAbsolute relativePath + +resolveDirectoryOption :: + String -> + Maybe FilePath -> + IO FilePath -> + IO FilePath +resolveDirectoryOption label maybePath defaultAction = do + path0 <- maybe defaultAction pure maybePath + path <- makeAbsolute path0 + validateDirectoryExists label path + pure path + +resolveFileOption :: + String -> + Maybe FilePath -> + IO FilePath -> + IO FilePath +resolveFileOption label maybePath defaultAction = do + path0 <- maybe defaultAction pure maybePath + path <- makeAbsolute path0 + validateFileExists label path + pure path + +resolveOptionalDirectory :: FilePath -> IO (Maybe FilePath) +resolveOptionalDirectory path0 = do + path <- makeAbsolute path0 + exists <- doesDirectoryExist path + pure if exists then Just path else Nothing + +validateDirectoryExists :: String -> FilePath -> IO () +validateDirectoryExists label path = do + exists <- doesDirectoryExist path + unless exists $ + die ("Missing " ++ label ++ ": " ++ path) + +validateFileExists :: String -> FilePath -> IO () +validateFileExists label path = do + exists <- doesFileExist path + unless exists $ + die ("Missing " ++ label ++ ": " ++ path) + +findMarkdownSources :: FilePath -> IO [FilePath] +findMarkdownSources contentDir = do + entries <- listDirectory contentDir + let candidatePaths = sortOn takeFileName (map (contentDir ) entries) + files <- filterM doesFileExist candidatePaths + pure + [ path + | path <- files, + let fileName = takeFileName path, + takeExtension fileName == ".md", + fileName `notElem` reservedMarkdownFiles + ] + +prepareStageRoot :: ResolvedOptions -> FilePath -> IO () +prepareStageRoot options stageRoot = do + createDirectoryIfMissing True stageRoot + + markdownFiles <- findMarkdownSources (resolvedContentDir options) + forM_ markdownFiles \path -> + linkOrCopyFile path (stageRoot takeFileName path) + + forM_ (resolvedImagesDir options) \path -> + linkOrCopyDirectory path (stageRoot "images") + + linkOrCopyFile (resolvedReferenceBib options) (stageRoot "reference.bib") + linkOrCopyFile (resolvedMathMacros options) (stageRoot "math-macros.md") + linkOrCopyDirectory (resolvedCssDir options) (stageRoot "css") + linkOrCopyDirectory (resolvedFontsDir options) (stageRoot "fonts") + linkOrCopyDirectory (resolvedTemplatesDir options) (stageRoot "templates") + linkOrCopyFile (resolvedBibStyle options) (stageRoot "bib_style.csl") + linkOrCopyFile (resolvedFavicon options) (stageRoot "favicon.ico") + +linkOrCopyFile :: FilePath -> FilePath -> IO () +linkOrCopyFile source destination = do + createDirectoryIfMissing True (takeDirectory destination) + result <- tryIOError (createFileLink source destination) + case result of + Right () -> pure () + Left _ -> copyFile source destination + +linkOrCopyDirectory :: FilePath -> FilePath -> IO () +linkOrCopyDirectory source destination = do + createDirectoryIfMissing True (takeDirectory destination) + result <- tryIOError (createDirectoryLink source destination) + case result of + Right () -> pure () + Left _ -> copyDirectoryRecursive source destination + +copyDirectoryRecursive :: FilePath -> FilePath -> IO () +copyDirectoryRecursive source destination = do + createDirectoryIfMissing True destination + entries <- listDirectory source + forM_ entries \entry -> do + let srcPath = source entry + dstPath = destination entry + isDirectory <- doesDirectoryExist srcPath + if isDirectory + then copyDirectoryRecursive srcPath dstPath + else copyFile srcPath dstPath + +-------------------------------------------------------------------------------- + +config :: ResolvedOptions -> Configuration +config options = defaultConfiguration - { ignoreFile = \path -> + { destinationDirectory = resolvedOutputDir options, + storeDirectory = resolvedStoreDir options, + tmpDirectory = resolvedTmpDir options, + providerDirectory = ".", + ignoreFile = \path -> ignoreFile defaultConfiguration path || ".git" `elem` splitDirectories (normalise path) } -main :: IO () -main = hakyllWith config $ do +siteRules :: Rules () +siteRules = do match "images/**" $ do route idRoute compile copyFileCompiler match "math-macros.md" $ compile getResourceBody - match "fonts/*.woff2" $ do + match "fonts/**" $ do route idRoute compile copyFileCompiler @@ -57,55 +407,11 @@ main = hakyllWith config $ do route idRoute compile copyFileCompiler - -- match "404.html" $ do - -- route cleanRoute - -- compile copyFileCompiler - - match "css/*" $ do + match "css/**" $ do route idRoute compile compressCssCompiler - -- match "about.md" $ do - -- route cleanRoute - -- compile $ - -- chaoDocCompiler - -- >>= loadAndApplyTemplate "templates/about.html" defaultContext - -- >>= relativizeUrls - - -- -- build up tags - -- tags <- buildTags "posts/*" (fromCapture "tags/*.html") - -- tagsRules tags $ \tag pattern -> do - -- let title = "Posts tagged \"" ++ tag ++ "\"" - -- route cleanRoute - -- compile $ do - -- posts <- recentFirst =<< loadAll pattern - -- let ctx = - -- constField "title" title - -- `mappend` listField "posts" (postCtxWithTags tags) (return posts) - -- `mappend` defaultContext - -- makeItem "" - -- >>= loadAndApplyTemplate "templates/tag.html" ctx - -- >>= loadAndApplyTemplate "templates/default.html" ctx - -- >>= relativizeUrls - - -- create ["tags.html"] $ do - -- route cleanRoute - -- compile $ do - -- makeItem "" - -- >>= loadAndApplyTemplate "templates/tags.html" (defaultCtxWithTags tags) - -- >>= loadAndApplyTemplate "templates/default.html" (defaultCtxWithTags tags) - - -- match "posts/*" $ do - -- route cleanRoute - -- compile $ do - -- tocCtx <- getTocCtx (postCtxWithTags tags) - -- chaoDocCompiler - -- >>= loadAndApplyTemplate "templates/post.html" tocCtx - -- >>= loadAndApplyTemplate "templates/default.html" tocCtx - -- >>= relativizeUrls - -- -- >>= katexFilter - - match "notes/*" $ do + match notePattern $ do route cleanRoute compile $ do notes <- loadNoteLinks @@ -113,6 +419,7 @@ main = hakyllWith config $ do chaoDocCompiler >>= loadAndApplyTemplate "templates/note.html" tocCtx >>= relativizeUrls + >>= cleanIndexHtmls create ["index.html"] $ do route idRoute @@ -128,103 +435,28 @@ main = hakyllWith config $ do >>= relativizeUrls >>= cleanIndexHtmls - -- create ["archive.html"] $ do - -- route cleanRoute - -- compile $ do - -- posts <- recentFirst =<< loadAll "posts/*" - -- let archiveCtx = - -- listField "posts" postCtx (return posts) - -- `mappend` constField "title" "Archives" - -- `mappend` defaultContext - -- makeItem "" - -- >>= loadAndApplyTemplate "templates/archive.html" archiveCtx - -- >>= loadAndApplyTemplate "templates/index.html" archiveCtx - -- >>= relativizeUrls - -- >>= cleanIndexHtmls - - -- create ["draft.html"] $ do - -- route cleanRoute - -- compile $ do - -- posts <- recentFirst =<< loadAll "posts/*" - -- let draftCtx = - -- listField "posts" postCtx (return posts) - -- `mappend` constField "title" "Drafts" - -- `mappend` defaultContext - -- makeItem "" - -- >>= loadAndApplyTemplate "templates/draft.html" draftCtx - -- >>= loadAndApplyTemplate "templates/index.html" draftCtx - -- >>= relativizeUrls - -- >>= cleanIndexHtmls - - -- match "index.html" $ do - -- route idRoute - -- compile $ do - -- posts <- fmap (take 25) . recentFirst =<< loadAll "posts/*" - -- let indexCtx = - -- listField "posts" postCtx (return posts) - -- `mappend` defaultContext - -- getResourceBody - -- >>= applyAsTemplate indexCtx - -- >>= loadAndApplyTemplate "templates/index.html" indexCtx - -- >>= relativizeUrls - -- >>= cleanIndexHtmls - match "templates/*" $ compile templateBodyCompiler --- https://robertwpearce.com/hakyll-pt-2-generating-a-sitemap-xml-file.html --- create ["sitemap.xml"] $ do --- route idRoute --- compile $ do --- posts <- recentFirst =<< loadAll "posts/*" --- singlePages <- loadAll (fromList ["about.md"]) --- let pages = posts <> singlePages --- sitemapCtx = --- constField "root" root --- <> listField "pages" postCtx (return pages) -- here --- makeItem "" --- >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx +main :: IO () +main = do + rawArgs <- getArgs + parseResult <- + case parseCliArgs rawArgs of + Left err -> die err + Right result -> pure result + case parseResult of + ShowHelp -> putStrLn helpText >> exitSuccess + Parsed cliOptions hakyllArgs -> do + resolved <- resolveCliOptions cliOptions + createDirectoryIfMissing True (resolvedStoreDir resolved) + createDirectoryIfMissing True (resolvedTmpDir resolved) + withSystemTempDirectory "hakysidian-stage" \stageRoot -> do + prepareStageRoot resolved stageRoot + withCurrentDirectory stageRoot $ + withArgs hakyllArgs $ + hakyllWith (config resolved) siteRules -------------------------------------------------------------------------------- - --- isZhField :: Context String --- isZhField = boolFieldM "isZh" isZh --- where --- isZh :: Item String -> Compiler Bool --- isZh item = do --- maybeLang <- getMetadataField (itemIdentifier item) "lang" --- return (maybeLang == Just "zh") - --- postCtx :: Context String --- postCtx = --- dateField "date" "%B %e, %Y" --- <> dateField "date" "%Y-%m-%d" --- <> isZhField --- <> defaultContext - --- postCtxWithTags :: Tags -> Context String --- postCtxWithTags tags = tagsField "tags" tags `mappend` postCtx - --- defaultCtxWithTags :: Tags -> Context String --- defaultCtxWithTags tags = listField "tags" tagsCtx getAllTags <> defaultContext --- where --- getAllTags :: Compiler [Item (String, [Identifier])] --- getAllTags = pure . map mkItem $ tagsMap tags --- where --- mkItem :: (String, [Identifier]) -> Item (String, [Identifier]) --- mkItem x@(t, _) = Item (tagsMakeId tags t) x --- tagsCtx = --- listFieldWith "posts" (postCtxWithTags tags) getPosts --- <> metadataField --- <> urlField "url" --- <> pathField "path" --- <> titleField "title" --- <> missingField --- where --- getPosts :: --- Item (String, [Identifier]) -> --- Compiler [Item String] --- getPosts (itemBody -> (_, is)) = mapM load is - -- toc from https://github.com/slotThe/slotThe.github.io getTocCtx :: Context a -> Compiler (Context a) getTocCtx ctx = do