gitja - Add Templates module to deal with templating

Commit 8186443d7455cef856b7a5d0de910c7715b50e77
Parent: 7bc13a85434b4ed6dc27695d6143265dd51d2f7b
Author: mcol <mcol@posteo.net>
Date: 2021-09-18 17:49:44 +0100
Committer: mcol <mcol@posteo.net>
Committed: 2021-09-18 17:49:44 +0100

Add Templates module to deal with templating

templates/log.html Added

@@ -0,0 +1,18 @@
+<!doctype html>
+<html lang="en">
+	<head>
+		<meta charset="utf-8">
+		<meta http-equiv="x-ua-compatible" content="ie=edge">
+		<meta name="viewport" content="width=device-width, initial-scale=1">
+		<title>gitserve - {{ title }}</title>
+		<link rel="stylesheet" href="{{ host }}/style.css" />
+	</head>
+
+	<body>
+		<p>{{ title }}</p>
+		<hr>
+		<p>{{ description }}</p>
+		<p>git clone {{ host }}{{ path }}</p>
+		{{ title }}
+	</body>
+</html>

src/Templates.hs Added

@@ -0,0 +1,49 @@
+module Templates (
+    Template,
+    templatePath,
+    templateContents,
+    loadTemplates,
+) where
+
+import Control.Monad (filterM, (<=<))
+import Data.Char (toLower)
+import Data.List (isSuffixOf)
+import System.Directory (doesFileExist, getDirectoryContents)
+import System.FilePath ((</>), FilePath)
+import System.IO.Error (tryIOError)
+
+import Config (Config, templateDirectory)
+
+data Template = Template
+    { templatePath :: FilePath
+    , templateContents :: String
+    }
+
+--tryLoad :: FilePath -> IO (Maybe String)
+--tryLoad path = do
+--    e <- tryIOError $ readFile path
+--    case e of
+--        Right contents ->
+--            return $ Just contents
+--        Left error -> do
+--            print error
+--            return Nothing
+
+loadTemplate :: FilePath -> IO Template
+loadTemplate path = do
+    contents <- readFile path
+    return $ Template path contents
+
+isTemplate :: FilePath -> IO Bool
+isTemplate path = ((&&) $ isTemplate' path) <$> (doesFileExist path)
+
+isTemplate' :: FilePath -> Bool
+isTemplate' path = isSuffixOf "html" p || isSuffixOf "css" p || isSuffixOf "js" p
+  where
+    p = map toLower path
+
+listTemplates :: FilePath -> IO [FilePath]
+listTemplates directory = fmap (directory </>) <$> getDirectoryContents directory
+
+loadTemplates :: Config -> IO [FilePath]
+loadTemplates = filterM isTemplate <=< listTemplates . templateDirectory

src/Repositories.hs Modified

@@ -31,3 +31,10 @@
             headCommit <- lookupCommit (Tagged commitID)
             liftIO $ print $ commitLog headCommit
         _ -> liftIO (print "Couldn't resolve HEAD")
+
+
+-- Variables:
+title = "gitserve"
+description = ""
+host = "http://localhost"
+path = ""

src/Main.hs Modified

@@ -3,6 +3,11 @@
 
 import Config (getConfig)
 import Repositories (run)
+import Templates (loadTemplates)
 
 main :: IO ()
-main = getConfig "./config.dhall" >>= run
+main = do
+    config <- getConfig "./config.dhall"
+    templates <- loadTemplates config
+    --run config templates
+    return ()

src/Config.hs Modified

@@ -3,6 +3,8 @@
 module Config (
     Config,
     repoPaths,
+    templateDirectory,
+    outputDirectory,
     getConfig
 ) where
 
@@ -10,6 +12,7 @@
 
 data Config = Config
     { repoPaths :: [FilePath]
+    , templateDirectory :: FilePath
     , outputDirectory :: FilePath
     }
     deriving (Generic, Show)

gitserve.cabal Modified

@@ -16,10 +16,14 @@
 executable gitserve
   hs-source-dirs:      src
   main-is:             Main.hs
-  other-modules:       Config, Repositories
+  other-modules:       Config, Repositories, Templates
   default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5
+                     , dhall
+                     , directory
+                     , filepath
+                     , ginger
                      , gitlib
                      , gitlib-libgit2
                      , tagged
-                     , dhall
+                     , text

config.dhall Modified

@@ -12,6 +12,7 @@
 -- This is the configuration object that is used by gitserve
 let config =
     { repoPaths = folders
+    , templateDirectory = "./templates"
     , outputDirectory = "./output"
     }