improve link rendering

Utils.hs

@@ -40,3 +40,9 @@ walkURLs f = Text.Pandoc.Walk.walkM go
       u' <- T.pack <$> f (T.unpack u)
       pure $ Image a i (u', t)
     go x = pure x
+
+hasUriScheme :: String -> String -> Bool
+hasUriScheme x = all id . zipWith (==) x . (++ ":")
+
+unAbsolute :: String -> String
+unAbsolute = dropWhile (== '/')

site.hs

@@ -66,7 +66,7 @@ loadPage fp = do
   md <- io $ runIOorExplode $ readMarkdown markdownReadOpts (T.drop 5 markdown)
   {- find the main mount point for the page -}
   let mount =
-        dropWhile (== '/') . T.unpack . just ("mount point of " ++ fp) $ yml ^?
+        unAbsolute . T.unpack . just ("mount point of " ++ fp) $ yml ^?
         key "mount" .
         _String
   existing <- use $ pages . to (M.!? mount)
@@ -127,14 +127,17 @@ checkTarget fp = do
 
 -- | Prepend the root path to the given link
 rootUrl :: FilePath -> Site FilePath
-rootUrl fp = (</> dropWhile (== '/') fp) <$> use urlBase
+rootUrl fp = (</> unAbsolute fp) <$> use urlBase
 
 -- | Process a single link pointing out from a page.
 processLink :: FilePath -> FilePath -> Site String
-processLink base l =
+processLink base l = do
-  if isAbsolute l
+  io $ putStrLn l
-    then rootUrl l
+  if any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"]
-    else installFile (base </> l) >>= rootUrl
+    then pure l
+    else if isAbsolute l
+           then rootUrl 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.)
@@ -186,7 +189,8 @@ installPageRedirects :: FilePath -> PageInfo -> Site ()
 installPageRedirects target pi = do
   traverse_
     (installRedirect target)
-    (pi ^.. pageMeta . key "redirects" . values . _String . to T.unpack)
+    (pi ^.. pageMeta . key "redirects" . values . _String . to T.unpack .
+     to unAbsolute)
 
 -- | Find the path to the file of a given hash
 dataFilename :: String -> FilePath -> Site (FilePath, FilePath)