src/Templates.hs Modified

@@ -8,6 +8,7 @@
     envIndexTemplate,
     envCommitTemplate,
     envFileTemplate,
+    envForce,
     -- The Template data type and its constructors.
     Template,
     templatePath,
@@ -18,20 +19,20 @@
     generate,
 ) where
 
-import Control.Monad (filterM)
+import Control.Monad (filterM, void)
 import Data.Char (toLower)
 import Data.List (isSuffixOf)
 import Data.Maybe (catMaybes)
 import Data.Text (unpack, Text)
 import qualified Data.HashMap.Strict as HashMap
 import System.Directory (doesFileExist, getDirectoryContents)
-import System.FilePath ((</>), takeFileName)
+import System.FilePath ((</>))
 import System.IO.Error (tryIOError)
 import qualified Text.Ginger.AST as G
 import Text.Ginger.Parse (SourcePos, parseGingerFile, peErrorMessage)
 import Text.Ginger.GVal (GVal)
 import Text.Ginger.Html (htmlSource, Html)
-import Text.Ginger.Run (easyRenderM, Run, RuntimeError)
+import Text.Ginger.Run (easyRenderM, Run)
 
 import Config
 
@@ -83,11 +84,10 @@
     :: FilePath
     -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
     -> Template
-    -> IO (Either (RuntimeError SourcePos) (GVal (Run SourcePos IO Html)))
+    -> IO ()
 generate output context template = do
-    let target = (output </>) . takeFileName . templatePath $ template
-    writeFile target ""  -- Clear contents of file if it exists
-    easyRenderM (writeTo target) context . templateGinger $ template
+    writeFile output ""  -- Clear contents of file if it exists
+    void $ easyRenderM (writeTo output) context . templateGinger $ template
 
 ----------------------------------------------------------------------------------------
 -- Private -----------------------------------------------------------------------------

src/Repositories.hs Modified

@@ -5,14 +5,12 @@
 
 module Repositories (
     run,
-    getDescription  -- Used by Index.hs::runIndex
 ) where
 
 import Conduit (runConduit, (.|), sinkList)
-import Control.Monad ((<=<))
+import Control.Monad ((<=<), when)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Reader (ReaderT)
-import Data.Either (fromRight)
 import Data.Tagged
 import Data.Text (pack, unpack, Text, isPrefixOf, stripPrefix, toLower)
 import Data.Text.Encoding (decodeUtf8With)
@@ -20,9 +18,8 @@
 import Data.Maybe (mapMaybe, catMaybes, fromJust)
 import Git
 import Git.Libgit2 (lgFactory, LgRepo)
-import System.Directory (createDirectoryIfMissing)
+import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath ((</>), takeFileName)
-import System.IO.Error (tryIOError)
 import Text.Ginger.GVal (GVal, toGVal, ToGVal)
 import Text.Ginger.Html (Html)
 import Text.Ginger.Run (Run)
@@ -30,23 +27,16 @@
 import qualified Data.HashMap.Strict as HashMap
 
 import Config
+import Index
 import Templates
 import Types
 
 {-
-This is the entrypoint that receives the ``Config`` and uses it to map over our
-repositories, reading from them and writing out their web pages using the given
-templates.
+This is the entrypoint maps over our repositories, reading from them and writing out
+their web pages using the loaded templates.
 -}
-run :: Env -> IO ()
-run env = mapM_ (processRepo env) (repoPaths . envConfig $ env)
-
-{-
-Pass the repository's folder, get its description. This is exported so that Index.hs can
-use it too.
--}
-getDescription :: FilePath -> IO Text
-getDescription = fmap (fromRight "") . tryIOError . fmap pack . readFile . (</> "description")
+run :: Env -> [Repo] -> IO ()
+run = mapM_ . processRepo
 
 
 ----------------------------------------------------------------------------------------
@@ -57,41 +47,32 @@
 repository doesn't exist or is unreadable in any way we can forget about it and move on
 (after informing the user of course).
 -}
-processRepo :: Env -> FilePath -> IO ()
-processRepo env path = withRepository lgFactory path $ processRepo' env path
+processRepo :: Env -> Repo -> IO ()
+processRepo env repo = withRepository lgFactory (Index.repoPath repo) $ processRepo' env repo
 
-processRepo' :: Env -> FilePath -> ReaderT LgRepo IO ()
-processRepo' env path = do
-    let name = takeFileName path
+processRepo' :: Env -> Repo -> ReaderT LgRepo IO ()
+processRepo' env repo = do
+    let name = takeFileName . Index.repoPath $ repo
     let output = outputDirectory (envConfig env) </> name
-    liftIO $ createDirectoryIfMissing True output
     resolveReference "HEAD" >>= \case
         Nothing -> liftIO . print $ "gitserve: " <> name <> ": Failed to resolve HEAD."
         Just commitID -> do
             let gitHead = Tagged commitID
-            -- Variables available in the ginger templates: --
 
-            -- description: The description of the repository from repo/description, if
-            -- it exists.
-            description <- liftIO . getDescription $ path
-
-            -- commits: A list of `Commit` objects to HEAD.
+            -- Collect variables available in the ginger templates --
             commits <- getCommits gitHead
-
-            -- tree: A list of `TreeFile` objects at HEAD.
             tree <- getTree gitHead
-
-            -- tags and branches: Lists of `Ref` objects that wrap `Commit` and
-            -- `Refname` (Text).
             tags <- getRefs "refs/tags/"
             branches <- getRefs "refs/heads/"
+            let scope = package env name (repoDescription repo) commits tree tags branches
 
             -- Run the generator --
-            let scope = package env name description commits tree tags branches
-            liftIO . mapM_ (generate output scope) $ envTemplates env
-            liftIO . mapM_ (genTarget output scope $ envCommitTemplate env) $ commits
-            liftIO . mapM_ (genTarget output scope $ envFileTemplate env) $ tree
-            return ()
+            liftIO . mapM_ (genRepo output scope) $ envTemplates env
+            let force = envForce env
+            liftIO . createDirectoryIfMissing True $ output </> "commits"
+            liftIO . createDirectoryIfMissing True $ output </> "files"
+            liftIO . mapM_ (genTarget output scope force $ envCommitTemplate env) $ commits
+            liftIO . mapM_ (genTarget output scope True $ envFileTemplate env) $ tree  -- TODO: detect file changes
 
 {-
 The role of the function above is to gather information about a git repository and
@@ -185,6 +166,14 @@
     dropName (Just _) name = Just name
     dropName Nothing _ = Nothing
 
+genRepo
+    :: FilePath
+    -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
+    -> Template
+    -> IO ()
+genRepo output scope template = generate output' scope template
+  where
+    output' = (</>) output . takeFileName . templatePath $ template
 
 ----------------------------------------------------------------------------------------
 -- Targets -----------------------------------------------------------------------------
@@ -212,13 +201,15 @@
     :: Target a
     => FilePath
     -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
+    -> Bool
     -> Maybe Template
     -> a
     -> IO ()
-genTarget _ _ Nothing _ = return ()
-genTarget output scope (Just template) target = do
-    let template' = template { templatePath = identify target }
-    let scope' = scope <> HashMap.fromList [(pack . category $ target, toGVal target)]
-    liftIO $ createDirectoryIfMissing True (output </> category target)
-    generate (output </> category target) scope' template'
-    return ()
+genTarget _ _ _ Nothing _ = return ()
+genTarget output scope force (Just template) target = do
+    let output' = output </> category target </> identify target
+    exists <- doesFileExist output'
+    when (force || not exists) $ do
+        print output'
+        let scope' = scope <> HashMap.fromList [(pack . category $ target, toGVal target)]
+        generate output' scope' template

src/Main.hs Modified

@@ -58,8 +58,8 @@
         else do
             conf <- getConfig (config options)
             env <- loadTemplates (force options) conf
-            runIndex env
-            run env
+            repos <- runIndex env
+            run env repos
 
 currentVersion :: String
 currentVersion = "0.0.0"

src/Index.hs Modified

@@ -5,13 +5,19 @@
 {-# Language InstanceSigs #-}  -- Needed for toGVal type signature
 
 module Index (
-    runIndex
+    runIndex,
+    Repo,
+    repoAsLookup,
+    repoPath,
+    repoDescription,
 ) where
 
 import Data.Default (def)
+import Data.Either (fromRight)
 import Data.Text (pack, Text)
 import System.Directory (createDirectoryIfMissing)
-import System.FilePath (takeFileName)
+import System.FilePath ((</>), takeFileName)
+import System.IO.Error (tryIOError)
 import Text.Ginger.GVal (GVal, toGVal, ToGVal, asText, asHtml, asLookup)
 import Text.Ginger.Html (Html, html)
 import Text.Ginger.Parse (SourcePos)
@@ -19,62 +25,77 @@
 import qualified Data.HashMap.Strict as HashMap
 
 import Config
-import Repositories
 import Templates
 
 {-
 This creates the main index file from the index template, using information from all
 configured respositories.
 -}
-runIndex :: Env -> IO ()
+runIndex :: Env -> IO [Repo]
 runIndex env =
     case envIndexTemplate env of
         Nothing ->
-            return ()
+            return []
         Just template -> do
             let config = envConfig env
             createDirectoryIfMissing True $ outputDirectory config
-            let paths = repoPaths config
-            descriptions <- mapM getDescription paths
-            let repos = zipWith ($) (Repo . takeFileName <$> paths) descriptions
+            let output = (outputDirectory config) </> "index.html"
+            repos <- loadRepos config
             let scope = packageIndex config repos
-            generate (outputDirectory config) scope (template { templatePath = "index.html" })
-            return ()
-
-----------------------------------------------------------------------------------------
--- Private -----------------------------------------------------------------------------
-
-{-
-This packages the variables that are available inside the index template.
--}
-packageIndex
-    :: Config
-    -> [Repo]
-    -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
-packageIndex config repos = HashMap.fromList
-    [ ("host", toGVal $ host config)
-    , ("repositories", toGVal repos)
-    ]
+            generate output scope template
+            return repos
 
 {-
 The unique variable in the index scope is the list of repositories, which can be looped
 over and each entry has some properties that can be accessed. Those are defined here.
+The type is exported so that within the scope of a single repository, its name and
+description is available.
 -}
 data Repo = Repo
-    { repoName :: FilePath
+    { repoPath :: FilePath
     , repoDescription :: Text
     }
 
 instance ToGVal m Repo where
     toGVal :: Repo -> GVal m
     toGVal repo = def
-        { asHtml = html . pack . show . repoName $ repo
-        , asText = pack . show . repoName $ repo
+        { asHtml = html . pack . show . takeFileName . repoPath $ repo
+        , asText = pack . show . takeFileName . repoPath $ repo
         , asLookup = Just . repoAsLookup $ repo
         }
 
 repoAsLookup :: Repo -> Text -> Maybe (GVal m)
 repoAsLookup repo = \case
-    "name" -> Just . toGVal . repoName $ repo
+    "name" -> Just . toGVal . takeFileName . repoPath $ repo
     "description" -> Just . toGVal . repoDescription $ repo
     _ -> Nothing
+
+
+----------------------------------------------------------------------------------------
+-- Private -----------------------------------------------------------------------------
+
+{-
+This packages the variables that are available inside the index template.
+-}
+packageIndex
+    :: Config
+    -> [Repo]
+    -> HashMap.HashMap Text (GVal (Run SourcePos IO Html))
+packageIndex config repos = HashMap.fromList
+    [ ("host", toGVal $ host config)
+    , ("repositories", toGVal repos)
+    ]
+
+{-
+Get paths along with their descriptions.
+-}
+loadRepos :: Config -> IO [Repo]
+loadRepos config = zipWith ($) (Repo <$> paths) <$> mapM getDescription paths
+  where
+    paths = repoPaths config
+
+{-
+Pass the repository's folder, get its description.
+-}
+getDescription :: FilePath -> IO Text
+getDescription = fmap (fromRight "") . tryIOError . fmap pack . readFile . (</> "description")