diff options
| -rw-r--r-- | Utils.hs | 17 | ||||
| -rw-r--r-- | external/mypage/text.md | 2 | ||||
| -rw-r--r-- | site.hs | 26 |
3 files changed, 34 insertions, 11 deletions
@@ -3,6 +3,11 @@ module Utils where import Control.Monad.IO.Class import Data.List.Extra (stripSuffix) import Data.Maybe (isJust) +import Text.Pandoc.Definition +import qualified Text.Pandoc.Walk +import qualified Data.Text as T + +import Types -- | A shortcut for `liftIO`. io :: MonadIO m => IO a -> m a @@ -20,3 +25,15 @@ hasSuffix s = isJust . stripSuffix s -- | The same second as from arrows et al. second :: (a -> b) -> (c, a) -> (c, b) second f (a, b) = (a, f b) + +-- | A pandoc walker for printing the URLs. +walkURLs :: (FilePath -> Site FilePath) -> Text.Pandoc.Definition.Pandoc -> Site Text.Pandoc.Definition.Pandoc +walkURLs f = Text.Pandoc.Walk.walkM go + where + go (Link a i (u,t)) = do + u' <- T.pack <$> f (T.unpack u) + pure $ Link a i (u',t) + go (Image a i (u,t)) = do + u' <- T.pack <$> f (T.unpack u) + pure $ Image a i (u',t) + go x = pure x diff --git a/external/mypage/text.md b/external/mypage/text.md index 4dc51cc..ac590d4 100644 --- a/external/mypage/text.md +++ b/external/mypage/text.md @@ -22,4 +22,4 @@ this that  more nonsense -haha [linek](/tags/) +haha [linek](/tags/or/something) @@ -22,7 +22,7 @@ import Hakyll.Core.Util.File (getRecursiveContents, makeDirectories) import Lens.Micro import Lens.Micro.Aeson import Lens.Micro.Mtl -import System.FilePath ((</>), splitDirectories, splitPath, takeFileName) +import System.FilePath ((</>), splitDirectories, splitPath, takeFileName, isAbsolute) import qualified Text.Mustache as Mu import Text.Pandoc.Class (runIOorExplode) import Text.Pandoc.Readers.Markdown (readMarkdown) @@ -106,22 +106,34 @@ checkTarget fp = do then error $ "colliding renders for page: " ++ fp else targets %= S.insert fp +-- | Process a single link pointing out from a page. +processLink :: FilePath -> String -> Site String +processLink base l = do + io $ putStrLn l + if isAbsolute l + then + pure l + else (do + io $ putStrLn "rel" + pure $ '/':(base</>l)) -- TODO + -- | Render a page using the current template. installPage :: FilePath -> PageInfo -> Site () installPage mount pi - {- find the correct template and metadata -} = do tname <- pageTemplate pi templ <- use $ templates . to (M.! fromString tname) file <- indexFilename mount + fixedUrlDoc <- walkURLs (processLink mount) $ pi ^. pageDoc checkTarget file io $ do putStrLn $ "P -> " ++ file makeDirectories file - body <- runIOorExplode $ writeHtml5String htmlWriteOpts (pi ^. pageDoc) + body <- runIOorExplode $ writeHtml5String htmlWriteOpts fixedUrlDoc let Y.Object meta' = pi ^. pageMeta meta = Y.Object $ KM.insert "body" (Y.String body) meta' TIO.writeFile file $ Mu.substitute templ meta + installPageRedirects mount pi {- | Install a simple redirect handler page. -} installRedirect :: FilePath -> FilePath -> Site () @@ -143,11 +155,6 @@ installPageRedirects target pi = do (installRedirect target) (pi ^.. pageMeta . key "redirects" . values . _String . to T.unpack) --- | Install all redirects required by all pages. -installRedirects :: Site () -installRedirects = - use pages >>= traverse_ (uncurry installPageRedirects) . M.assocs - -- | Find the path to the file of a given hash dataFilename :: String -> FilePath -> Site (FilePath, FilePath) dataFilename hash basename = do @@ -184,7 +191,7 @@ installAsset :: FilePath -> Site () installAsset fp = do od <- use outputDir ad <- use assetDir - let [src,dst] = map (</> fp) [ad,od] + let [src, dst] = map (</> fp) [ad, od] checkTarget dst io $ do putStrLn $ "A -> " ++ src ++ " -> " ++ dst @@ -226,7 +233,6 @@ main = sourceTags sourceTemplates "templates" use pages >>= traverse (uncurry installPage) . M.assocs - installRedirects installFile "external/mypage/img/awesome.png" io $ putStrLn "OK" get >>= io . print |