install files properly

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.

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)
+      pure $ Link a i (u', t)
-    go (Image a i (u,t)) = do
+    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

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
+sourcePages fp =
-  links <-
+  io
-    io $ filter (hasSuffix ".md" . last . splitPath) <$>
+    (map (fp </>) . filter (hasSuffix ".md" . last . splitPath) <$>
-    getRecursiveContents (pure . const False) fp
+     getRecursiveContents (pure . const False) fp) >>=
-  traverse_ loadPage (map (fp </>) links)
+  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 :: FilePath -> FilePath -> Site String
-processLink base l = do
+processLink base l =
   if isAbsolute l
-    then pure l -- TODO prepend the root url
+    then rootUrl l
-    else (do io . putStrLn $ "rel:" ++ l
+    else installFile (base </> l) >>= rootUrl
-             pure $ '/' : (base </> l) -- TODO
-          )
 
 -- | 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