diff --git a/Types.hs b/Types.hs index 12088b6..8e53611 100644 --- a/Types.hs +++ b/Types.hs @@ -44,6 +44,8 @@ data SiteState = , _defaultTemplate :: FilePath -- ^ Name of the default template , _redirectTemplate :: FilePath -- ^ Name of the template for redirect pages , _tagTemplate :: FilePath -- ^ Name of the template for tag listing pages + , _urlBase :: FilePath -- ^ "Root route" to prepend to all absolute links. + , _dumpFinalState :: Bool -- ^ Triggers printing out the structure when the processing finishes. } deriving (Show) @@ -63,6 +65,8 @@ emptySiteState = , _defaultTemplate = "default.html" , _redirectTemplate = "redirect.html" , _tagTemplate = "tag.html" + , _urlBase = "/" + , _dumpFinalState = False } -- | Monad for running the site generator. diff --git a/Utils.hs b/Utils.hs index c220cb7..ea0b1ec 100644 --- a/Utils.hs +++ b/Utils.hs @@ -3,9 +3,9 @@ module Utils where import Control.Monad.IO.Class import Data.List.Extra (stripSuffix) import Data.Maybe (isJust) +import qualified Data.Text as T import Text.Pandoc.Definition import qualified Text.Pandoc.Walk -import qualified Data.Text as T import Types @@ -27,13 +27,16 @@ second :: (a -> b) -> (c, a) -> (c, b) second f (a, b) = (a, f b) -- | A pandoc walker for modifying the URLs. -walkURLs :: (FilePath -> Site FilePath) -> Text.Pandoc.Definition.Pandoc -> Site Text.Pandoc.Definition.Pandoc +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 + 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 + 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) + pure $ Image a i (u', t) go x = pure x diff --git a/site.hs b/site.hs index dafe23f..affb61d 100644 --- a/site.hs +++ b/site.hs @@ -4,6 +4,7 @@ module Main where import Control.Monad ((>=>), unless, when) +import Control.Monad.Extra (whenM) import Control.Monad.Trans.State.Lazy import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy as B @@ -27,6 +28,7 @@ import System.FilePath , isAbsolute , splitDirectories , splitPath + , takeDirectory , takeFileName ) import qualified Text.Mustache as Mu @@ -41,11 +43,11 @@ import Utils -- | Load the pages from a directory and add them to `pages`. sourcePages :: FilePath -> Site () -sourcePages fp = do - links <- - io $ filter (hasSuffix ".md" . last . splitPath) <$> - getRecursiveContents (pure . const False) fp - traverse_ loadPage (map (fp ) links) +sourcePages fp = + io + (map (fp ) . filter (hasSuffix ".md" . last . splitPath) <$> + getRecursiveContents (pure . const False) fp) >>= + traverse_ loadPage {- | Extract `PageInfo` about a single page and save it into `pages` in - `SiteState`. -} @@ -122,18 +124,17 @@ checkTarget fp = do -- | Prepend the root path to the given link rootUrl :: FilePath -> Site FilePath -rootUrl = pure . ('/' :) +rootUrl fp = ( fp) <$> use urlBase -- | Process a single link pointing out from a page. -processLink :: FilePath -> String -> Site String -processLink base l = do +processLink :: FilePath -> FilePath -> Site String +processLink base l = if isAbsolute l - then pure l -- TODO prepend the root url - else (do io . putStrLn $ "rel:" ++ l - pure $ '/' : (base l) -- TODO - ) + 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.) pageFilename :: FilePath -> Site FilePath pageFilename = indexFilename @@ -151,7 +152,8 @@ installPage mount pi = do tname <- pageTemplate pi templ <- use $ templates . to (M.! fromString tname) file <- pageFilename mount - fixedUrlDoc <- walkURLs (processLink mount) $ pi ^. pageDoc + fixedUrlDoc <- + walkURLs (processLink $ pi ^. pagePath . to takeDirectory) $ pi ^. pageDoc checkTarget file io $ do putStrLn $ "P -> " ++ file @@ -322,8 +324,5 @@ main = sourceTemplates "templates" use pages >>= traverse (uncurry installPage) . M.assocs renderTags - -- testing part begin - installFile "external/mypage/img/awesome.png" - -- testing part end io $ putStrLn "OK" - get >>= io . print + whenM (use dumpFinalState) $ get >>= io . print