Commit f325deaa authored by Nicolas Lenz's avatar Nicolas Lenz

A lot of refactoring

parent 0b1bd8a7
Pipeline #162 passed with stage
in 2 minutes and 43 seconds
......@@ -6,10 +6,10 @@ author: "Nicolas Lenz"
maintainer: "nicolas@eisfunke.com"
copyright: "2019 Nicolas Lenz"
extra-source-files:
extra-doc-files:
- README.md
synopsis: A static blog generator using Pandoc.
synopsis: A static website generator using Pandoc.
category: Web
description: Please see the README at <https://git.eisfunke.com/software/nebelhorn#readme>
......@@ -22,23 +22,20 @@ dependencies:
- text
- pandoc
- pandoc-types
- containers
- containers # For Map
- yaml
- aeson
- aeson-casing
- blaze-html
- process
- exceptions
default-extensions:
- NoImplicitPrelude
- OverloadedStrings
- LambdaCase
- RecordWildCards
executables:
nebelhorn:
main: Main.hs
source-dirs: src
main: main.hs
source-dirs: src
ghc-options:
- -Wall
- -Wno-name-shadowing
......
{-# LANGUAGE LambdaCase, RecordWildCards, QuasiQuotes #-}
{-# LANGUAGE QuasiQuotes #-}
module Build (build) where
import ClassyPrelude hiding ((</>))
import Config
import File
import Path
import Path.IO
import System.Process
import Text.Pandoc
import qualified Data.Map as Map
(<$$>) :: (Functor f1, Functor f2) => (a -> b) -> (f1 (f2 a)) -> (f1 (f2 b))
{- |
A handy nested map function. Works just like the normal inline map '<$>', but nested.
Example: @(+1) <$$> [[1, 2], [3, 4]]@ evaluates to @[[2, 3], [4, 5]]@.
-}
(<$$>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)
(<$$>) = fmap . fmap
-- | Predicate that checks whether a file is a markdown file using the file extension.
isMarkdownFile :: Path b File -> Bool
isMarkdownFile path = ext == ".md" || ext == ".markdown" where ext = fileExtension path
-- | Reads all markdown files from a folder recursively, returning their contents and paths (relative to the folder path).
load :: MonadIO m => Path b Dir -> m [(Path Rel File, Text)]
load basePath = do
(_, filesAll) <- listDirRecurRel basePath
let files = filter isMarkdownFile filesAll
contents <- liftIO $ mapM readFileUtf8 (toFilePath . (basePath </>) <$> files)
return $ zip files contents
-- | Saves a list of file contents with their relative paths to a folder, converting them to HTML5.
save :: (MonadIO m) => Path b Dir -> [(Path Rel File, Text)] -> m ()
save basePath = mapM_ $ \(path, output) -> do
let fileOutput = basePath </> path
ensureDir $ parent fileOutput
writeFileUtf8 (toFilePath fileOutput) output
getNavbarMeta :: [Navitem] -> MetaValue
getNavbarMeta navItems = MetaList $ map (\Navitem{..} -> MetaMap $ Map.fromList [("name", MetaString $ unpack navitemName), ("link", MetaString $ unpack navitemLink)]) navItems
read :: (PandocMonad m) => Text -> m Pandoc
read = readMarkdown readerOptions where
readerOptions = def {readerExtensions = pandocExtensions}
-- TODO: Deduplicate
readPages :: (PandocMonad m, MonadIO m) => Meta -> [(Path Rel File, Text)] -> m [(Path Rel File, Pandoc)]
readPages extraMeta inputs = do
outputs <- forM inputs $ \(path, content) -> do
contentR <- read content
return (path, contentR)
outputs <- forM outputs $ \(path, content) -> liftIO $ do
newPath <- setFileExtension ".html" path -- TODO: This should really be done without IO...
return (newPath, content)
let outputs' = addMeta extraMeta <$$> outputs
return outputs'
readArticles :: (PandocMonad m, MonadIO m) => Meta -> [(Path Rel File, Text)] -> m (Pandoc, [(Path Rel File, Pandoc)])
readArticles extraMeta inputs = do
outputs <- forM inputs $ \(path, content) -> do
contentR <- read content
return (path, contentR)
outputs <- forM outputs $ \(path, content) -> liftIO $ do
newPath <- setFileExtension ".html" path -- TODO: This should really be done without IO...
return (newPath, content)
let outputs' = addMeta extraMeta <$$> outputs
return (generateIndex extraMeta outputs', outputs')
-- | The monadic equivalent of the nested map '<$$>'.
mapMT :: (Traversable t1, Traversable t2, Monad m) => (a -> m b) -> t1 (t2 a) -> m (t1 (t2 b))
mapMT = mapM . mapM
-- | Generate the Pandoc MetaValue for a navbar from a list of NavItem from a Nebelhorn config.
generateNavbarMeta :: [NavItem] -> MetaValue
generateNavbarMeta navItems = MetaList $ map (\NavItem{..} -> MetaMap $ Map.fromList [("name", MetaString $ unpack navItemName), ("link", MetaString $ unpack navItemLink)]) navItems
-- | Reads in a single document to a Pandoc value using an extra Meta.
read :: (PandocMonad m, MonadIO m) => Meta -> (Path Rel File, Text) -> m (Path Rel File, Pandoc)
read extraMeta (path, content) = do
contentR <- read' content
newPath <- liftIO $ setFileExtension ".html" path -- TODO: This should really be done without IO...
return (newPath, addMeta extraMeta contentR)
where read' = readMarkdown $ def {readerExtensions = pandocExtensions}
-- | Writes a single Pandoc document to HTML5 output using a template.
write :: (PandocMonad m) => Text -> Pandoc -> m Text
write template = writeHtml5String writerOptions where
writerOptions = def {writerExtensions = pandocExtensions, writerTemplate = Just $ unpack template}
buildPages :: (PandocMonad m, MonadIO m) => Text -> MetaValue -> [(Path Rel File, Text)] -> m [(Path Rel File, Text)]
buildPages template navbar inputs = do
pagesInput <- readPages extraMeta inputs
f `mapM` pagesInput
-- | Builds a list of pages, using a MetaValue for the navbar, from raw markdown to HTML5.
buildPages :: (PandocMonad m, MonadIO m)
=> MetaValue -> [(Path Rel File, Text)] -> m [(Path Rel File, Text)]
buildPages navbar inputs = do
template <- readFileUtf8 "template/page.html"
pagesInput <- read extraMeta `mapM` inputs
write template `mapMT` pagesInput
where
extraMeta = Meta $ Map.fromList [("navbar", navbar)]
f (path, content) = do
contentW <- write template content
return (path, contentW)
buildArticles :: (PandocMonad m, MonadIO m) => Text -> Text -> MetaValue -> [(Path Rel File, Text)] -> m (Text, [(Path Rel File, Text)])
buildArticles templateArticle templateIndex navbar inputs = do
(indexInput, articlesInput) <- readArticles extraMeta inputs
articlesOutput <- f `mapM` articlesInput
-- | Builds a list of articles, using a MetaValue for the navbar, from raw markdown to HTML5.
buildArticles :: (PandocMonad m, MonadIO m)
=> MetaValue -> [(Path Rel File, Text)] -> m (Text, [(Path Rel File, Text)])
buildArticles navbar inputs = do
templateArticle <- readFileUtf8 "template/article.html"
templateIndex <- readFileUtf8 "template/index.html"
articlesInput <- read extraMeta `mapM` inputs
let indexInput = generateIndex extraMeta articlesInput
articlesOutput <- write templateArticle `mapMT` articlesInput
indexOutput <- write templateIndex indexInput
return (indexOutput, articlesOutput)
where
extraMeta = Meta $ Map.fromList [("navbar", navbar)]
f (path, content) = do
contentW <- write templateArticle content
return (path, contentW)
-- | Generate an index page from a list of Articles.
generateIndex :: Meta -> [(Path Rel File, Pandoc)] -> Pandoc
generateIndex extraMeta = generateIndex' . sortOn (Down . (\(_, Pandoc meta _) -> lookupMeta "date" meta)) where
generateIndex' :: [(Path Rel File, Pandoc)] -> Pandoc
generateIndex extraMeta = generateIndex' . sort where
sort = sortOn (Down . (\(_, Pandoc meta _) -> lookupMeta "date" meta))
generateIndex' articles = Pandoc metaOutput [] where
metaOutput = extraMeta <> Meta (Map.fromList [("pagetitle", MetaString "Home"), ("articles", MetaList articlesOutput)])
articlesOutput = (uncurry generateIndexMeta) <$> articles
-- | Generates the Pandoc MetaMap for a document for the index page. It contains the meta of the source, the link and the body
-- | Generates the Pandoc MetaMap for a document for the index page. It contains the meta of the source, the link and the body.
generateIndexMeta :: Path Rel File -> Pandoc -> MetaValue
generateIndexMeta path (Pandoc (Meta metaMap) body) = MetaMap $ metaMap
<> Map.fromList [("link", MetaString $ toFilePath path), ("body", MetaBlocks body)]
-- | Adds a Meta block to a pandocument. Already known keys are overwritten.
addMeta :: Meta -> Pandoc -> Pandoc
addMeta (Meta metaMapExtra) (Pandoc (Meta metaMap) blocks) = Pandoc (Meta $ metaMapExtra `Map.union` metaMap) blocks
copyFolders :: Config -> IO ()
copyFolders Config{..} = do
folders <- mapM parseRelDir configFoldersToCopy
forM_ folders $ \folder -> copyDirRecur folder ([reldir|out|] </> folder)
addMeta (Meta metaMapExtra) (Pandoc (Meta metaMap) blocks)
= Pandoc (Meta $ metaMapExtra `Map.union` metaMap) blocks
-- | Compile the stylesheet using sassc.
compileStylesheet :: IO ()
compileStylesheet = callCommand "sassc style/stylesheet.scss out/style/stylesheet.css"
build :: IO ()
build = loadConfig >>= \case
Left ex -> fail $ "Error while reading config: " <> show ex
Right config@Config{..} -> do
copyFolders config
Right Config{..} -> do
copyFolders configFoldersToCopy configOutputFolder
compileStylesheet
templateArticle <- readFileUtf8 configTemplateArticle
templatePage <- readFileUtf8 configTemplatePage
templateIndex <- readFileUtf8 configTemplateIndex
articlesInput <- (\(path, pandoc) -> ([reldir|article|] </> path, pandoc)) <$$> load [reldir|article|]
articlesInput <- prependPath <$$> load [reldir|article|]
pagesInput <- load [reldir|page|]
articlesOutputE <- runIO (buildArticles templateArticle templateIndex (getNavbarMeta $ configNavbar) articlesInput)
pagesOutputE <- runIO (buildPages templatePage (getNavbarMeta $ configNavbar) pagesInput)
articlesOutputE <- runIO (buildArticles (generateNavbarMeta configNavbar) articlesInput)
pagesOutputE <- runIO (buildPages (generateNavbarMeta configNavbar) pagesInput)
let outputE = do{
(indexOutput, articlesOutput) <- articlesOutputE;
pagesOutput <- pagesOutputE;
return (indexOutput, articlesOutput, pagesOutput)}
case outputE of
Left ex -> fail $ "Error while processing articles: " <> show ex
Right (indexOutput, articlesOutput, pagesOutput) -> do
save [reldir|out|] articlesOutput
save [reldir|out|] pagesOutput
writeFileUtf8 "out/index.html" indexOutput
save configOutputFolder articlesOutput
save configOutputFolder pagesOutput
save configOutputFolder [([relfile|index.html|], indexOutput)]
putStrLn "Success!"
where prependPath (path, pandoc) = ([reldir|article|] </> path, pandoc)
{-# LANGUAGE DeriveGeneric, RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
module Config where
import ClassyPrelude
import Data.Yaml
import Data.Aeson (genericParseJSON)
import Data.Aeson.Casing
import Path
data Config = Config {
configTemplateArticle :: FilePath,
configTemplatePage :: FilePath,
configTemplateIndex :: FilePath,
configFoldersToCopy :: [FilePath],
configNavbar :: [Navitem]
} deriving (Show, Generic)
configOutputFolder :: Path Rel Dir,
configFoldersToCopy :: [Path Rel Dir],
configNavbar :: [NavItem]
} deriving (Show)
data Navitem = Navitem {
navitemName :: Text,
navitemLink :: Text
} deriving (Show, Generic)
data NavItem = NavItem {
navItemName :: Text,
navItemLink :: Text
} deriving (Show)
instance FromJSON Config where
parseJSON = genericParseJSON $ aesonPrefix camelCase
parseJSON = withObject "Config" $ \v -> Config
<$> v .:? "outputFolder" .!= [reldir|out|]
<*> v .:? "foldersToCopy" .!= []
<*> v .:? "navbar" .!= [NavItem "Home" "/index.html"]
instance FromJSON Navitem where
parseJSON = genericParseJSON $ aesonPrefix camelCase
instance FromJSON NavItem where
parseJSON = withObject "NavItem" $ \v -> NavItem
<$> v .: "name"
<*> v .: "link"
loadConfig :: IO (Either ParseException Config)
loadConfig = decodeFileEither "nebelhorn.yaml"
module File (load, save, copyFolders) where
import ClassyPrelude hiding ((</>))
import Path
import Path.IO
-- | Predicate that checks whether a file is a markdown file using the file extension.
isMarkdownFile :: Path b File -> Bool
isMarkdownFile path = ext == ".md" || ext == ".markdown"
where ext = fileExtension path
-- | Reads all markdown files from a folder recursively,
-- returning their contents and paths (relative to the folder path).
load :: MonadIO m => Path b Dir -> m [(Path Rel File, Text)]
load basePath = do
(_, filesAll) <- listDirRecurRel basePath
let files = filter isMarkdownFile filesAll
contents <- liftIO $ readFileUtf8 `mapM` (toFilePath . (basePath </>) <$> files)
return $ zip files contents
-- | Saves a list of files to the specified paths relative to a base path.
save :: (MonadIO m) => Path b Dir -> [(Path Rel File, Text)] -> m ()
save basePath = mapM_ $ \(path, output) -> do
let fileOutput = basePath </> path
ensureDir $ parent fileOutput
writeFileUtf8 (toFilePath fileOutput) output
-- | Copies folders verbatim according to the target folder.
copyFolders :: [Path Rel Dir] -> Path a Dir -> IO ()
copyFolders sources sink = forM_ sources $ \source -> copyDirRecur source (sink </> source)
module Main where
import ClassyPrelude
import Build
main :: IO ()
main = build
{-
\case
Right config -> do
dir <- getCurrentDirectory
runIO (liftIO (compileStylesheet config) >> processPages config dir >> processArticles config dir) >>= \case
Left err -> putStrLn $ "An error occured during processing:\n" <> tshow err
Right _ -> putStrLn "Successfully sounded through the fog."
Left exception -> putStrLn $ "The configuration file couldn't be read:\n" <> pack (prettyPrintParseException exception)-}
{-# LANGUAGE RecordWildCards #-}
module Style where
import ClassyPrelude
import Config
import ClassyPrelude
import Build
main :: IO ()
main = build
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment