From d8f3bc3c708219bca4168d42a736d53abc33ef86 Mon Sep 17 00:00:00 2001
From: James Eversole <james@eversole.co>
Date: Sun, 18 Feb 2024 14:26:11 -0600
Subject: [PATCH] Compositional HTML fragments

---
 sampu.cabal               | 13 +++++++------
 src/Core/Configuration.hs |  2 +-
 src/Core/HTTP.hs          | 19 ++++++++++---------
 src/Core/Handlers.hs      | 10 +++++++---
 src/Templates/Base.hs     | 16 +++++++++-------
 5 files changed, 34 insertions(+), 26 deletions(-)

diff --git a/sampu.cabal b/sampu.cabal
index 6aef47b..484380b 100644
--- a/sampu.cabal
+++ b/sampu.cabal
@@ -13,19 +13,20 @@ executable sampu
     import:             warnings
     main-is:            Main.hs
     default-extensions: OverloadedStrings
+    ghc-options:        -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
     build-depends:      base
                       , bytestring >= 0.11.5.0
                       , commonmark >= 0.2.4
                       , dotenv     >= 0.11.0.0
                       , lucid      >= 2.11.0
+                      , text       >= 2.0
                       , twain      >= 2.1.0.0
                       , wai-extra  >= 3.0 && < 3.2
                       , warp       == 3.3.25
     hs-source-dirs:     src
-    other-modules:
-      Core.Configuration
-      Core.Handlers
-      Core.HTTP
-      Core.Rendering
-      Templates.Base
+    other-modules:      Core.Configuration
+                        Core.Handlers
+                        Core.HTTP
+                        Core.Rendering
+                        Templates.Base
     default-language:   GHC2021
diff --git a/src/Core/Configuration.hs b/src/Core/Configuration.hs
index 7634bb1..181fbb9 100644
--- a/src/Core/Configuration.hs
+++ b/src/Core/Configuration.hs
@@ -1,7 +1,7 @@
 module Core.Configuration where
 
 import Configuration.Dotenv
-import System.Environment (getEnv, lookupEnv)
+import System.Environment   (getEnv, lookupEnv)
 
 main :: IO ()
 main = do
diff --git a/src/Core/HTTP.hs b/src/Core/HTTP.hs
index 78f4eda..ad8f095 100644
--- a/src/Core/HTTP.hs
+++ b/src/Core/HTTP.hs
@@ -1,29 +1,30 @@
 module Core.HTTP where
 
-import qualified Core.Configuration as Conf
-import qualified Core.Handlers      as Handle
+import qualified Core.Configuration         as Conf
+import qualified Core.Handlers              as Handle
 
 import Network.Wai.Middleware.RequestLogger (logStdoutDev)
-import Network.Wai.Handler.Warp (Port, run)
+import Network.Wai.Handler.Warp             (Port, run)
 import Web.Twain
 
+-- Get the port to listen on from the ENV and start the webserver
 main :: IO ()
 main = do
   port <- Conf.appPort
   run (read port :: Int) $
     foldr ($) (notFound Handle.missing) app
 
--- Combine our Preprocessor Middlewares and Routes to create an App
-app :: [Middleware]
-app = preProcessors ++ routes
-
--- These Middleware are always executed before any routes are reached
+-- These Middlewares are always executed before any routes are reached
 preProcessors :: [Middleware]
 preProcessors = [logStdoutDev]
 
--- The application's core routes expressed as a list of WAI middlewares
+-- The application's routes expressed as a list of WAI Middlewares
 routes :: [Middleware]
 routes =
   [ get "/" Handle.index
   , get "/echo/:testParam" Handle.testRoute
   ]
+
+-- Combine our Preprocessor Middlewares and Routes to create an App to run
+app :: [Middleware]
+app = preProcessors ++ routes
diff --git a/src/Core/Handlers.hs b/src/Core/Handlers.hs
index a5f5227..13f34b0 100644
--- a/src/Core/Handlers.hs
+++ b/src/Core/Handlers.hs
@@ -1,12 +1,16 @@
 module Core.Handlers where
 
-import qualified Templates.Base as T
-import           Core.Rendering as R
+import qualified Core.Configuration     as Conf
+import qualified Core.Rendering         as R
+import qualified Templates.Base         as T
 
+import Control.Monad.IO.Class (liftIO)
 import Web.Twain
 
 index :: ResponderM a
-index = send $ html $ R.twain T.baseNav
+index = liftIO Conf.appTitle >>= (\title -> 
+  send $ html $ R.twain $
+  T.baseDoc title T.baseNav)
 
 testRoute :: ResponderM a
 testRoute = do
diff --git a/src/Templates/Base.hs b/src/Templates/Base.hs
index 6fccd6f..74a14b6 100644
--- a/src/Templates/Base.hs
+++ b/src/Templates/Base.hs
@@ -1,13 +1,15 @@
 module Templates.Base where
 
+import Data.Text
+import Data.String (fromString)
 import Lucid
 
-baseNav :: Html ()
-baseNav = doctypehtml_ $ do
+baseDoc :: String -> Html () -> Html ()
+baseDoc title nav = doctypehtml_ $ do
   head_ $ do
-    title_ getBlogTitle
+    title_ (fromString title)
     link_ [rel_ "stylesheet", type_ "text/css", href_ "style.css"]
-  body_ $ do
-    h1_ "This will be a nav eventually."
-  where
-    getBlogTitle = "unimplemented getEnv"
+  body_ nav
+
+baseNav :: Html ()
+baseNav = h1_ "This will be a nav eventually."