add mount: URI scheme that allows folks to have somewhat relative links

1 files changed, 22 insertions, 10 deletions

diff --git a/reploy.hs b/reploy.hs
index b94046d..dbdb091 100644
--- a/reploy.hs
+++ b/reploy.hs
@@ -46,6 +46,7 @@ import System.FilePath
   ( isAbsolute
   , joinPath
   , splitFileName
+  , splitPath
   , takeDirectory
   , takeFileName
   )
@@ -175,15 +176,25 @@ rootedLink :: FilePath -> Site FilePath
 rootedLink = (<*>) rootedLink' . pure
 
 -- | Process a single link pointing out from a page.
-processLink :: FilePath -> FilePath -> Site String
-processLink base l =
-  if any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"]
-       || take 1 l == "#"
-    then pure l
-    else if isAbsolute l
-           then let (path, rest) = break (`elem` ['?', '#']) l
-                 in (<> rest) <$> rootedPageLink path
-           else installFile (base </> l) >>= rootedLink
+processLink :: FilePath -> FilePath -> FilePath -> Site String
+processLink base mount l
+  | any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"] || take 1 l == "#" =
+    pure l
+  | isAbsolute l =
+    let (path, rest) = break (`elem` ['?', '#']) l
+     in (<> rest) <$> rootedPageLink path
+  | l `hasUriScheme` "mount" =
+    let (path, rest) = break (`elem` ['?', '#']) $ drop 6 l
+        mountpath =
+          joinPath . reverse
+            $ foldl interpretPath (reverse $ splitPath mount) (splitPath path)
+        interpretPath m x
+          | x `elem` ["..", "../"] = drop 1 m
+          | x `elem` [".", "./"] = m
+          | x == "/" = ["/"]
+          | otherwise = x : m
+     in (<> rest) <$> rootedPageLink mountpath
+  | otherwise = installFile (base </> l) >>= rootedLink
 
 -- | Conjure a function that finds a displayable name for a page at a particular mount.
 pageName' :: Site (FilePath -> String)
@@ -290,7 +301,8 @@ installPage mount pi = do
   templ <- use $ templates . to (M.! fromString tname)
   file <- indexFilename mount
   fixedUrlDoc <-
-    walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc
+    walkURLs (processLink (pi ^. pagePath . to takeDirectory) mount)
+      $ pi ^. pageDoc
   checkTarget file
   body <-
     io . runIOorExplode