link modification works

Utils.hs

@@ -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

external/mypage/text.md

@@ -22,4 +22,4 @@ this that
 ![awesome](img/awesome.png)
 
 more nonsense
-haha [linek](/tags/)
+haha [linek](/tags/or/something)

site.hs

@@ -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