mad/byg/src/SiteGenerator.hs

module SiteGenerator (generateSite) where

import Prelude hiding (String, FilePath)

import Types
import DependencyGenerator

import Control.Monad (forM_)
import Data.Text (Text)

thumbnailImageFilename :: Token FilePath -> DepGenM' FilePath
thumbnailImageFilename filename = do
  (base, ext) <- untupleDepGenM $ fileComponents filename
  suffix <- inject "-thumbnail."
  concatStrings [ base, suffix, ext ]

makeImageHTML :: Token (FilePath, FilePath) -> DepGenM' Text
makeImageHTML t = do
  (thumbnail, actual) <- untupleDepGenM t
  concatTexts [ inject "<p class=\"image\"><a href=\""
              , toText actual
              , inject "\"><img src=\""
              , toText thumbnail
              , inject "\"></a></p>"
              ]

hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM' Bool
hasExtension exts filename = do
  ext <- lowerString $ untupleSndDepGenM $ fileComponents filename
  ext `elemOf` exts

handleRecipeDir :: Token FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM ()
handleRecipeDir outputDir template indexName dir = do
  recipeDirOut <- joinPaths outputDir dir
  makeDir recipeDirOut
  dirContents <- listDirectory dir
  imageFilenames <- filterDepGenM (hasExtension $ inject ["jpg"]) dirContents
  imagePaths <- mapDepGenM (joinPaths dir) imageFilenames
  imagePathsOut <- mapDepGenM (joinPaths recipeDirOut) imageFilenames
  mapDepGenM_ copyFile' $ zipDepGenM imagePaths imagePathsOut
  thumbnailImageFilenames <- mapDepGenM thumbnailImageFilename imageFilenames
  thumbnailImagePaths <- mapDepGenM (joinPaths recipeDirOut) thumbnailImageFilenames
  mapDepGenM_
    (\files -> convertImage files $ inject $ ResizeToWidth 800)
    (zipDepGenM imagePaths thumbnailImagePaths)
  md <- readTextFile $ joinPaths dir $ inject "ret.md"
  ingredienserHeadline <- inject "## Ingredienser"
  mdTemplate <- makeTemplate md ingredienserHeadline
  htmlBodyImages <- mapDepGenM makeImageHTML $ zipDepGenM thumbnailImageFilenames imageFilenames
  imagesHtml <- concatTexts htmlBodyImages
  md' <- applyTemplate mdTemplate
    $ concatTexts [ inject "<p class=\"imagetext\">Opskrift fortsætter efter billedet.</p>\n"
                  , pure imagesHtml
                  , inject "\n\n"
                  , pure ingredienserHeadline
                  ]
  htmlBody <- runPandoc md'
  html <- applyTemplate template htmlBody
  saveFile html $ joinPaths recipeDirOut indexName

generateSite :: DepGenM ()
generateSite = do
  outputDir <- inject "site"
  makeDir outputDir
  recipesDir <- inject "retter"
  makeDir $ joinPaths outputDir recipesDir
  template <- makeTemplate (readTextFile (inject "template.html")) (inject "CONTENT")
  indexName <- inject "index.html"
  dirNames <- listDirectory recipesDir
  dirPaths <- mapDepGenM (joinPaths recipesDir) dirNames
  dirPaths' <- filterDepGenM isDirectory dirPaths
  mapDepGenM_ (handleRecipeDir outputDir template indexName) dirPaths'
  html <- applyTemplate template $ runPandoc $ readTextFile $ inject "om.md"
  aboutDir <- joinPaths outputDir $ inject "om"
  makeDir aboutDir
  saveFile html $ joinPaths aboutDir indexName
  styleName <- inject "style.css"
  copyFile styleName (joinPaths outputDir styleName)
  imgName <- inject "img"
  imgPathOut <- joinPaths outputDir imgName
  makeDir imgPathOut
  forM_ ["mad-icon.png", "mad-logo.png"] $ \name -> do
    val <- inject name
    copyFile (joinPaths imgName val) (joinPaths imgPathOut val)
  fontsDir <- inject "fonts"
  fontsNames <- listDirectory fontsDir
  fontsPaths <- mapDepGenM (joinPaths fontsDir) fontsNames
  fontsPaths' <- filterDepGenM isDirectory fontsPaths
  makeDir (joinPaths outputDir fontsDir)
  mapDepGenM_ (handleFontDir outputDir) fontsPaths'

handleFontDir :: Token FilePath -> Token FilePath -> DepGenM ()
handleFontDir outputDir fontPath = do
  makeDir (joinPaths outputDir fontPath)
  files <- listDirectory fontPath
  paths <- mapDepGenM (joinPaths fontPath) files
  paths' <- filterDepGenM (hasExtension $ inject ["woff2", "css"]) paths
  mapDepGenM_ (\p -> copyFile p (joinPaths outputDir p)) paths'