diff options
Diffstat (limited to 'reploy.hs')
| -rw-r--r-- | reploy.hs | 358 |
1 files changed, 124 insertions, 234 deletions
@@ -14,22 +14,21 @@ - under the License. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} --- | The main site deployment executable. +-- | The main site deployment executable module. module Main where -import Control.Monad (filterM, join, unless, when) +import Control.Monad ((>=>), join, unless, when) import Control.Monad.Extra (whenM) import Control.Monad.Trans.State.Lazy import qualified Data.Aeson as AE import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM -import Data.Bool (bool) import qualified Data.ByteString.Lazy as B import Data.Digest.Pure.SHA (sha256, showDigest) import Data.Foldable (traverse_) import Data.List (inits, nub, sort) -import Data.List.Extra (groupSort) import qualified Data.Map as M import qualified Data.Scientific import qualified Data.Set as S @@ -47,9 +46,7 @@ import System.FilePath ( (</>) , isAbsolute , joinPath - , splitDirectories , splitFileName - , splitPath , takeDirectory , takeFileName ) @@ -63,24 +60,19 @@ import Text.Pandoc.Writers.HTML (writeHtml5String) import Text.Pandoc.Writers.Shared (toTableOfContents) import qualified Text.Parsec.Error +import AesonUtils import FormatOpts +import Tags import Types import Utils -import AesonUtils - --- | Check if a given path should be sourced or not -isSourceablePath :: FilePath -> Site Bool -isSourceablePath fp = do - notSource <- use notSourceDirs - pure $ (&&) <$> hasSuffix ".md" . last <*> not . any (`elem` notSource) . init $ - splitDirectories fp -- | Load the pages from a directory and add them to `pages`. sourcePages :: FilePath -> Site () -sourcePages fp = - (io $ getRecursiveContents (pure . const False) fp) >>= - filterM isSourceablePath >>= - traverse_ (loadPage . (fp </>)) +sourcePages fp = sourcePaths fp go + where + go p + | hasSuffix ".md" (takeFileName p) = loadPage (fp </> p) + | otherwise = pure () {- | Extract `PageInfo` about a single page and save it into `pages` in - `SiteState`. -} @@ -148,7 +140,8 @@ sourceTemplates templdir = do indexFilename :: FilePath -> Site FilePath indexFilename mount = do od <- use outputDir - pure (od </> mount </> "index.html") + idxf <- use indexFile + pure (od </> mount </> idxf) -- | Check that the page was not rendered before, and add it to the rendered set checkTarget :: FilePath -> Site () @@ -158,22 +151,31 @@ checkTarget fp = do then error $ "colliding renders for page: " ++ fp else targets %= S.insert fp --- | Prepend the root path to the given link -rootUrl' :: FilePath -> FilePath -> FilePath -rootUrl' root = (root </>) . unAbsolute - --- | Same as `rootUrl'` but conveniently in the monad -rootUrl :: FilePath -> Site FilePath -rootUrl fp = flip rootUrl' fp <$> use urlBase - --- | Like `rootUrl'` but also appends @index.html@ for systems that don't have --- working directory indexes. -rootPageUrl' :: FilePath -> Bool -> FilePath -> FilePath -rootPageUrl' root index fp = bool id (</> "index.html") index $ rootUrl' root fp - --- | Convenient version of `rootPageUrl'` -rootPageUrl :: FilePath -> Site FilePath -rootPageUrl fp = rootPageUrl' <$> use urlBase <*> use appendUrlIndex <*> pure fp +-- | Conjure a function that transforms absolute links to pages to full rooted +-- URLs. +rootedPageLink' :: Site (FilePath -> FilePath) +rootedPageLink' = do + ub <- use urlBase + app <- use appendUrlIndex + if app + then pure (ub </>) + else do + idxf <- use indexFile + pure $ \x -> ub </> x </> idxf + +-- | Transform a link to page to a full rooted URL +rootedPageLink :: FilePath -> Site FilePath +rootedPageLink = (<*>) rootedPageLink' . pure + +-- | Conjure a function that transforms absolute links to files to rooted URLs. +rootedLink' :: Site (FilePath -> FilePath) +rootedLink' = do + ub <- use urlBase + pure (ub </>) + +-- | Transform a link to file to a rooted URL. +rootedLink :: FilePath -> Site FilePath +rootedLink = (<*>) rootedLink' . pure -- | Process a single link pointing out from a page. processLink :: FilePath -> FilePath -> Site String @@ -182,32 +184,28 @@ processLink base l = "#" then pure l else if isAbsolute l - then rootPageUrl l - else installFile (base </> l) >>= rootUrl - --- | Get a mount point of the page into the correct location. --- (Pages are currently mounted just to the root.) -pageFilename :: FilePath -> Site FilePath -pageFilename = indexFilename + then rootedPageLink l + else installFile (base </> l) >>= rootedLink -- | Like `Mu.substitute` but writes (and eventually should throw) stuff on errors checkedSubstitute :: Mu.Template -> MT.Value -> IO T.Text checkedSubstitute t v = do let (es, txt) = Mu.checkedSubstitute t v traverse_ (putStrLn . ("Error: " ++) . show) es - --null es `unless` error "template substitution problems" + --null es `unless` error "template substitution problems!" pure txt -- | Add global information to page metadata for rendering (at this point just the url base) addGlobalMeta :: Y.Value -> Site MT.Value addGlobalMeta (Y.Object m) = do r <- use urlBase - i <- use appendUrlIndex + rt <- rootedLink' + rtp <- rootedPageLink' let l = map (\(k, v) -> (K.toText k, Mu.toMustache v)) $ KM.toList m pure . Mu.object $ l ++ [ ("root", Mu.toMustache $ T.pack r) - , ("rawRootUrl", Mu.overText $ T.pack . rootUrl' r . T.unpack) - , ("pageLink", Mu.overText $ T.pack . rootPageUrl' r i . T.unpack) + , ("rawRootUrl", Mu.overText $ T.pack . rt . T.unpack) + , ("pageLink", Mu.overText $ T.pack . rtp . T.unpack) ] -- | Get the expected timestamp file for a given filepath @@ -222,13 +220,16 @@ addExtraMeta pi m = do metaPath <- metadataFile $ pi ^. pagePath metaExists <- io $ doesFileExist metaPath gem <- use extraMeta - objMerge gem <$> if metaExists - then do - em' <- io $ Y.decodeFileEither metaPath - case em' of - Left pe -> error $ "decoding " ++ metaPath ++ " failed: " ++ Y.prettyPrintParseException pe - Right em -> pure $ objMerge em m - else pure m + objMerge gem <$> + if metaExists + then do + em' <- io $ Y.decodeFileEither metaPath + case em' of + Left pe -> + error $ "decoding " ++ metaPath ++ " failed: " ++ + Y.prettyPrintParseException pe + Right em -> pure $ objMerge em m + else pure m -- | Add page-specific information to the metadata. In this instance, this just -- expands the tags for rendering and continues by adding extra metadata via @@ -236,11 +237,11 @@ addExtraMeta pi m = do addPageMeta :: PageInfo -> Y.Value -> Site Y.Value addPageMeta pi (Y.Object m) = do htagMeta <- - traverse (makeHTagMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" . + traverse (htagRenderMeta tagLink) . sort $ pi ^.. pageMeta . key "tags" . values . _String . to T.unpack . - to splitDirectories + to splitTag addExtraMeta pi . Y.Object $ KM.insert "htags" (Y.array htagMeta) m -- | If viable for a page (by config), add the TOC field @@ -263,7 +264,7 @@ installPage :: FilePath -> PageInfo -> Site () installPage mount pi = do tname <- pageTemplate pi templ <- use $ templates . to (M.! fromString tname) - file <- pageFilename mount + file <- indexFilename mount fixedUrlDoc <- walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc checkTarget file @@ -282,7 +283,7 @@ installPage mount pi = do {- | Install a simple redirect handler page. -} installRedirect :: FilePath -> FilePath -> Site () installRedirect target' from = do - target <- rootPageUrl target' + target <- rootedPageLink target' tname <- use redirectTemplate templ <- use $ templates . to (M.! fromString tname) file <- indexFilename from @@ -340,7 +341,7 @@ installAsset ad fp = do let [src, dst] = map (</> fp) [ad, od] checkTarget dst io $ do - putStrLn $ "A -> " ++ src ++ " -> " ++ dst + putStrLn $ "A " ++ src ++ " -> " ++ dst copy src dst -- | Copy all files from a given asset directory. @@ -353,207 +354,96 @@ installAssetDir ad = installAssets :: Site () installAssets = use assetDirs >>= traverse_ installAssetDir --- | Load tag names from a directory and add them to `tagNames`. -sourceTagnames :: FilePath -> Site () -sourceTagnames fp = - io - (map (fp </>) . filter ((== "tagnames.yml") . last . splitPath) <$> - getRecursiveContents (pure . const False) fp) >>= - traverse_ sourceTagnameFile - --- | Single item for `sourceTagnames` -sourceTagnameFile :: FilePath -> Site () -sourceTagnameFile fp = do - yml' <- - io $ do - putStrLn $ "# <- " ++ fp - Y.decodeFileEither fp - case yml' of - Left err -> - error $ "Failed to load tagnames from " ++ fp ++ ": " ++ Y.prettyPrintParseException err - Right yml -> traverse_ add $ KM.toList (yml :: KM.KeyMap String) - where add :: (KM.Key, String) -> Site () - add (k, v) = - let go (Just ov) = - if v == ov - then Just ov - else error - ("conflicting tag names for tag " ++ K.toString k) - go Nothing = Just v - in tagNames %= M.alter go (K.toString k) - --- | Find the humanized name for a tag piece -getTagName :: String -> Site String -getTagName t = handleEmpty . maybe t id <$> use (tagNames . to (M.!? t)) - where - handleEmpty "" = "all" - handleEmpty x = x - --- | Get all tags from the pages of the site. -sourceTags :: Site () -sourceTags = do - sgat <- - map - (second $ map splitDirectories . - (^.. pageMeta . key "tags" . values . _String . to T.unpack)) . - M.assocs <$> - use pages - ehtags .= M.fromList (invExpandTags sgat) - htags .= M.fromList (invTags sgat) - --- | Organize a list of pages with hierarchical tags to a list with --- hierarchical tags with pages attached; with tags implying parents. -invExpandTags :: [(FilePath, [[String]])] -> [([String], [FilePath])] -invExpandTags x = - map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, ht <- htl, t <- inits ht] - --- | Like `invExpandTags` but without the expansion. -invTags :: [(FilePath, [[String]])] -> [([String], [FilePath])] -invTags x = map (fmap nub) $ groupSort [(t, p) | (p, htl) <- x, t <- htl] - --- | Get the destination for the tag page. -tagFilename :: FilePath -> Site FilePath -tagFilename tag = indexFilename $ "tag" </> tag - -- | Get the destination for the tag page. -listFilename :: FilePath -> Site FilePath -listFilename tag = indexFilename $ "list" </> tag - --- | Fold the hierarchical tag bits to a slashed path. -tagPath :: [String] -> FilePath -tagPath = joinPath +tagFilename :: [String] -> Site FilePath +tagFilename = indexFilename . joinPath . ("tag" :) -- | Make a link to the tag page tagLink :: [String] -> Site FilePath -tagLink = rootPageUrl . ("tag" </>) . tagPath +tagLink = rootedPageLink . joinPath . ("tag" :) --- | Fold the hierarchical tag bits to a slashed path. -listPath :: [String] -> FilePath -listPath = joinPath +-- | Get the destination for the tag page. +listFilename :: [String] -> Site FilePath +listFilename = indexFilename . joinPath . ("list" :) -- | Make a link to the tag page listLink :: [String] -> Site FilePath -listLink = rootPageUrl . ("list" </>) . listPath - --- | Make metadata for printing out a single hierarchical tag (all levels clickable) -makeHTagMeta :: ([String] -> Site FilePath) -> [String] -> Site Y.Value -makeHTagMeta lf tag = do - links <- traverse lf (inits tag) - tags <- traverse getTagName ("" : tag) - pure . Y.array $ - zipWith - (\t l -> Y.object [("tag", fromString t), ("href", fromString l)]) - tags - links +listLink = rootedPageLink . joinPath . ("list" :) -- | Make metadata for printing out a link to a page -makePageLinkMeta :: FilePath -> Site Y.Value -makePageLinkMeta mount = do - link <- rootPageUrl mount +makePageLinkRenderMeta :: FilePath -> Site Y.Value +makePageLinkRenderMeta mount = do + link <- rootedPageLink mount meta <- use $ pages . to (M.! mount) . pageMeta - pure $ Y.object [("href", fromString link), ("meta", meta)] - --- | Like `makeTagMeta`, but returns only plain YAML without the functions (in --- outcome the result is easier to work with using the YAML machinery, --- allowing this to recurse to itself). -makeTagMeta' :: [String] -> Site Y.Value -makeTagMeta' tag = do - taggedPages <- use $ htags . to (M.!? tag) . to (maybe [] id) - subtags <- - gets - (^.. ehtags . to M.keys . each . filtered (not . null) . - filtered ((== tag) . init)) - htagMeta <- makeHTagMeta tagLink tag - subtagsMeta <- Y.array <$> traverse makeTagMeta' subtags - pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages - link <- tagLink tag - listlink <- listLink tag - tags <- Y.array . map fromString <$> traverse getTagName tag pure $ Y.object - [ ("href", fromString link) - , ("tags", tags) - , ("htag", htagMeta) - , ("subtags", subtagsMeta) - , ("pages", pagesMeta) - , ("listhref", fromString listlink) - ] - --- | Create the complete metadata structure for the template that renders a given categorical tag pages -makeTagMeta :: [String] -> Site MT.Value -makeTagMeta tag = makeTagMeta' tag >>= addGlobalMeta - --- | Make metadata for printing out a single tag as-is, without levels -makeHTagLinkMeta :: [String] -> Site Y.Value -makeHTagLinkMeta tag = do - link <- listLink tag - tags <- Y.array . map fromString <$> traverse getTagName tag - pure $ Y.object [("href", fromString link), ("tags", tags)] - --- | Create the structure for rendering a complete listing of one hierarchical tag. -makeListMeta :: [String] -> Site MT.Value -makeListMeta tag = do - taggedPages <- use $ ehtags . to (M.! tag) - subtags <- - gets - (^.. ehtags . to M.keys . each . filtered (not . null) . - filtered ((== tag) . init)) - htagMeta <- makeHTagMeta listLink tag - subtagsMeta <- Y.array <$> traverse makeHTagLinkMeta subtags - pagesMeta <- Y.array <$> traverse makePageLinkMeta taggedPages - tl <- tagLink tag - addGlobalMeta $ - Y.object - [ ("htag", htagMeta) - , ("subtags", subtagsMeta) - , ("pages", pagesMeta) - , ("taghref", fromString tl) - ] - --- | Render a site for a given tag string. -renderTag :: [String] -> Site () -renderTag tag = do - tname <- use tagTemplate - templ <- use $ templates . to (M.! fromString tname) - file <- tagFilename (tagPath tag) - checkTarget file - meta <- makeTagMeta tag - io $ do - putStrLn $ "# -> " ++ file - makeDirectories file - checkedSubstitute templ meta >>= TIO.writeFile file + [("mount", fromString mount), ("href", fromString link), ("meta", meta)] --- | Render all tag sites. -renderTags :: Site () -renderTags = use (ehtags . to M.keys) >>= traverse_ renderTag +wrapPagesMeta :: Y.Value -> String -> FilePath -> Y.Value +wrapPagesMeta x linkname link = + Y.object [("pages", x), (fromString linkname, fromString link)] --- | Render a site for a given tag string. -renderList :: [String] -> Site () -renderList tag = do - tname <- use listTemplate - templ <- use $ templates . to (M.! fromString tname) - file <- listFilename (listPath tag) +makeTagRenderMeta :: [String] -> Site Y.Value +makeTagRenderMeta = htagRenderMetaWithSubtags tagLink extra makeTagRenderMeta + where + extra htag = do + meta <- exactlyTaggedPagesRenderMeta makePageLinkRenderMeta htag + wrapPagesMeta meta "listhref" <$> listLink htag + +makeListRenderMeta :: [String] -> Site Y.Value +makeListRenderMeta = + htagRenderMetaWithSubtags + listLink + pr + (htagRenderMetaWithSubtags + listLink + (const $ pure (Y.object [])) + (const $ pure Y.Null)) + where + pr htag = do + meta <- allTaggedPagesRenderMeta makePageLinkRenderMeta htag + wrapPagesMeta meta "taghref" <$> tagLink htag + +-- | Parametrized render of a listing-style site. +renderListing :: + String + -> ([String] -> Site FilePath) + -> ([String] -> Site MT.Value) + -> String + -> [String] + -> Site () +renderListing templName fileName makeMeta mark htag = do + templ <- (M.! fromString templName) <$> use templates + file <- fileName htag checkTarget file - meta <- makeListMeta tag + meta <- makeMeta htag io $ do - putStrLn $ "* -> " ++ file + putStrLn $ (mark ++ " -> " ++ file) makeDirectories file checkedSubstitute templ meta >>= TIO.writeFile file --- | Render all tag sites. -renderLists :: Site () -renderLists = use (ehtags . to M.keys) >>= traverse_ renderList +renderTags = do + lt <- use tagTemplate + M.keys <$> use ehtags >>= + traverse_ + (renderListing lt tagFilename (makeTagRenderMeta >=> addGlobalMeta) "#") + +renderLists = do + lt <- use listTemplate + M.keys <$> use ehtags >>= + traverse_ + (renderListing lt listFilename (makeListRenderMeta >=> addGlobalMeta) "*") -- | Transform one mounted PageInfo to the base search data -mkSearchData :: FilePath -> PageInfo -> Site [Y.Value] -mkSearchData mount pi = do - link <- rootPageUrl mount +makeSearchData :: FilePath -> PageInfo -> Site [Y.Value] +makeSearchData mount pi = do + link <- rootedPageLink mount text <- io . runIOorExplode $ writePlain plainWriteOpts (pi ^. pageDoc) let title = pi ^? pageMeta . key "title" . _String -- TODO: unify retrieval of tags let tags = sort $ pi ^.. pageMeta . key "tags" . values . _String . to T.unpack - tagnames <- traverse (traverse getTagName . splitDirectories) tags + tagnames <- traverse (traverse getTagGroupName . inits . splitTag) tags let tagarray = Y.array . map (Y.array . map fromString) $ tagnames if pi ^? pageMeta . key "search" . _Bool == Just False -- `off` gets parsed as bool then pure [] @@ -571,7 +461,7 @@ renderSearchData :: Site () renderSearchData = use searchDataOut >>= traverse_ go where go out = do - ps <- use (pages . to M.assocs) >>= traverse (uncurry mkSearchData) + ps <- use (pages . to M.assocs) >>= traverse (uncurry makeSearchData) io $ do putStrLn $ "S -> " ++ out AE.encodeFile out $ Y.array (concat ps) @@ -582,7 +472,7 @@ main = do flip runStateT init $ do installAssets use sourceDirs >>= traverse sourcePages - use sourceDirs >>= traverse sourceTagnames + use sourceDirs >>= traverse sourceTagMeta sourceTags use templateDir >>= sourceTemplates use pages >>= traverse (uncurry installPage) . M.assocs |