Chapter 7 - Environment

Author: soupi

app/Main.hs

@@ -15,8 +15,8 @@ main :: IO ()
 main = do
   options <- parse
   case options of
-    ConvertDir input output ->
-      HsBlog.convertDirectory input output
+    ConvertDir input output env ->
+      HsBlog.convertDirectory env input output
 
     ConvertSingle input output -> do
       (title, inputHandle) <-

app/OptParse.hs

@@ -11,6 +11,7 @@ module OptParse
   where
 
 import Data.Maybe (fromMaybe)
+import HsBlog.Env
 import Options.Applicative
 
 ------------------------------------------------
@@ -19,7 +20,7 @@ import Options.Applicative
 -- | Model
 data Options
   = ConvertSingle SingleInput SingleOutput
-  | ConvertDir FilePath FilePath
+  | ConvertDir FilePath FilePath Env
   deriving Show
 
 -- | A single input source
@@ -114,7 +115,7 @@ pOutputFile = OutputFile <$> parser
 
 pConvertDir :: Parser Options
 pConvertDir =
-  ConvertDir <$> pInputDir <*> pOutputDir
+  ConvertDir <$> pInputDir <*> pOutputDir <*> pEnv
 
 -- | Parser for input directory
 pInputDir :: Parser FilePath
@@ -135,3 +136,32 @@ pOutputDir =
       <> metavar "DIRECTORY"
       <> help "Output directory"
     )
+
+-- | Parser for blog environment
+pEnv :: Parser Env
+pEnv =
+  Env <$> pBlogName <*> pStylesheet
+
+-- | Blog name parser
+pBlogName :: Parser String
+pBlogName =
+  strOption
+    ( long "name"
+      <> short 'N'
+      <> metavar "STRING"
+      <> help "Blog name"
+      <> value (eBlogName defaultEnv)
+      <> showDefault
+    )
+
+-- | Stylesheet parser
+pStylesheet :: Parser String
+pStylesheet =
+  strOption
+    ( long "style"
+      <> short 'S'
+      <> metavar "FILE"
+      <> help "Stylesheet filename"
+      <> value (eStylesheetPath defaultEnv)
+      <> showDefault
+    )

hs-blog.cabal

@@ -33,10 +33,12 @@ library
       base
     , directory
     , filepath
+    , mtl
   exposed-modules:
     HsBlog
       HsBlog.Convert
       HsBlog.Directory
+      HsBlog.Env
       HsBlog.Html
         HsBlog.Html.Internal
       HsBlog.Markup

src/HsBlog.hs

@@ -12,13 +12,14 @@ import qualified HsBlog.Markup as Markup
 import qualified HsBlog.Html as Html
 import HsBlog.Convert (convert)
 import HsBlog.Directory (convertDirectory, buildIndex)
+import HsBlog.Env (defaultEnv)
 
 import System.IO
 
-convertSingle :: Html.Title -> Handle -> Handle -> IO ()
+convertSingle :: String -> Handle -> Handle -> IO ()
 convertSingle title input output = do
   content <- hGetContents input
   hPutStrLn output (process title content)
 
-process :: Html.Title -> String -> String
-process title = Html.render . convert title . Markup.parse
+process :: String -> String -> String
+process title = Html.render . convert defaultEnv title . Markup.parse

src/HsBlog/Convert.hs

@@ -2,11 +2,25 @@
 
 module HsBlog.Convert where
 
+import Prelude hiding (head)
+import HsBlog.Env (Env(..))
 import qualified HsBlog.Markup as Markup
 import qualified HsBlog.Html as Html
 
-convert :: Html.Title -> Markup.Document -> Html.Html
-convert title = Html.html_ title . foldMap convertStructure
+convert :: Env -> String -> Markup.Document -> Html.Html
+convert env title doc =
+  let
+    head =
+      Html.title_ (eBlogName env <> " - " <> title)
+        <> Html.stylesheet_ (eStylesheetPath env)
+    article =
+      foldMap convertStructure doc
+    websiteTitle =
+      Html.h_ 1 (Html.link_ "index.html" $ Html.txt_ $ eBlogName env)
+    body =
+      websiteTitle <> article
+  in
+    Html.html_ head body
 
 convertStructure :: Markup.Structure -> Html.Structure
 convertStructure structure =

src/HsBlog/Directory.hs

@@ -11,10 +11,12 @@ module HsBlog.Directory
 import qualified HsBlog.Markup as Markup
 import qualified HsBlog.Html as Html
 import HsBlog.Convert (convert, convertStructure)
+import HsBlog.Env (Env(..))
 
 import Data.List (partition)
 import Data.Traversable (for)
 import Control.Monad (void, when)
+import Control.Monad.Reader (Reader, runReader, ask)
 
 import System.IO (hPutStrLn, stderr)
 import Control.Exception (catch, displayException, SomeException(..))
@@ -38,12 +40,12 @@ import System.Directory
 --   '.html' files in the process. Recording unsuccessful reads and writes to stderr.
 --
 -- May throw an exception on output directory creation.
-convertDirectory :: FilePath -> FilePath -> IO ()
-convertDirectory inputDir outputDir = do
+convertDirectory :: Env -> FilePath -> FilePath -> IO ()
+convertDirectory env inputDir outputDir = do
   DirContents filesToProcess filesToCopy <- getDirFilesAndContent inputDir
   createOutputDirectoryOrExit outputDir
   let
-    outputHtmls = txtsToRenderedHtml filesToProcess
+    outputHtmls = runReader (txtsToRenderedHtml filesToProcess) env
   copyFiles outputDir filesToCopy
   writeFiles outputDir outputHtmls
   putStrLn "Done."
@@ -77,8 +79,9 @@ data DirContents
 ------------------------------------
 -- * Build index page
 
-buildIndex :: [(FilePath, Markup.Document)] -> Html.Html
-buildIndex files =
+buildIndex :: [(FilePath, Markup.Document)] -> Reader Env Html.Html
+buildIndex files = do
+  env <- ask
   let
     previews =
       map
@@ -92,9 +95,10 @@ buildIndex files =
               Html.h_ 3 (Html.link_ file (Html.txt_ file))
         )
         files
-  in
-    Html.html_
-      "Blog"
+  pure $ Html.html_
+      ( Html.title_ (eBlogName env)
+        <> Html.stylesheet_ (eStylesheetPath env)
+      )
       ( Html.h_ 1 (Html.link_ "index.html" (Html.txt_ "Blog"))
         <> Html.h_ 2 (Html.txt_ "Posts")
         <> mconcat previews
@@ -104,20 +108,22 @@ buildIndex files =
 -- * Conversion
 
 -- | Convert text files to Markup, build an index, and render as html.
-txtsToRenderedHtml :: [(FilePath, String)] -> [(FilePath, String)]
-txtsToRenderedHtml txtFiles =
+txtsToRenderedHtml :: [(FilePath, String)] -> Reader Env [(FilePath, String)]
+txtsToRenderedHtml txtFiles = do
   let
     txtOutputFiles = map toOutputMarkupFile txtFiles
-    index = ("index.html", buildIndex txtOutputFiles)
-  in
-    map (fmap Html.render) (index : map convertFile txtOutputFiles)
+  index <- (,) "index.html" <$> buildIndex txtOutputFiles
+  htmlPages <- traverse convertFile txtOutputFiles
+  pure $ map (fmap Html.render) (index : htmlPages)
 
 toOutputMarkupFile :: (FilePath, String) -> (FilePath, Markup.Document)
 toOutputMarkupFile (file, content) =
   (takeBaseName file <.> "html", Markup.parse content)
 
-convertFile :: (FilePath, Markup.Document) -> (FilePath, Html.Html)
-convertFile (file, doc) = (file, convert file doc)
+convertFile :: (FilePath, Markup.Document) -> Reader Env (FilePath, Html.Html)
+convertFile (file, doc) = do
+  env <- ask
+  pure (file, convert env (takeBaseName file) doc)
 
 ------------------------------------
 -- * Output to directory

src/HsBlog/Env.hs

@@ -0,0 +1,13 @@
+-- | src/HsBlog/Env.hs
+
+module HsBlog.Env where
+
+data Env
+  = Env
+    { eBlogName :: String
+    , eStylesheetPath :: FilePath
+    }
+  deriving Show
+
+defaultEnv :: Env
+defaultEnv = Env "My Blog" "style.css"

src/HsBlog/Html.hs

@@ -2,7 +2,10 @@
 
 module HsBlog.Html
   ( Html
-  , Title
+  , Head
+  , title_
+  , stylesheet_
+  , meta_
   , Structure
   , html_
   , h_

src/HsBlog/Html/Internal.hs

@@ -2,6 +2,7 @@
 
 module HsBlog.Html.Internal where
 
+import Prelude hiding (head)
 import Numeric.Natural
 
 -- * Types
@@ -15,20 +16,40 @@ newtype Structure
 newtype Content
   = Content String
 
-type Title
-  = String
+newtype Head
+  = Head String
 
 -- * EDSL
 
-html_ :: Title -> Structure -> Html
-html_ title content =
+html_ :: Head -> Structure -> Html
+html_ (Head head) content =
   Html
     ( el "html"
-      ( el "head" (el "title" (escape title))
+      ( el "head" head
         <> el "body" (getStructureString content)
       )
     )
 
+-- * Head
+
+title_ :: String -> Head
+title_ = Head . el "title" . escape
+
+stylesheet_ :: FilePath -> Head
+stylesheet_ path =
+  Head $ "<link rel=\"stylesheet\" type=\"text/css\" href=\"" <> escape path <> "\">"
+
+meta_ :: String -> String -> Head
+meta_ name content =
+  Head $ "<meta name=\"" <> escape name <> "\" content=\"" <> escape content <> "\">"
+
+instance Semigroup Head where
+  (<>) (Head h1) (Head h2) =
+    Head (h1 <> h2)
+
+instance Monoid Head where
+  mempty = Head ""
+
 -- * Structure
 
 p_ :: Content -> Structure