diff --git a/Utils.hs b/Utils.hs index ea0b1ec..4828335 100644 --- a/Utils.hs +++ b/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 (== '/') diff --git a/site.hs b/site.hs index 45bc7b2..600589d 100644 --- a/site.hs +++ b/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 = - if isAbsolute l - then rootUrl l - else installFile (base l) >>= rootUrl +processLink base l = do + io $ putStrLn l + if any (l `hasUriScheme`) ["http", "https", "ftp", "mailto"] + 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)