A lot of refactoring

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>

- 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

    main: main.hs

    source-dirs: src

    ghc-options:

    - -Wall

{-# 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)-}