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
  appendStrings base
    $ appendStrings (inject "-thumbnail.") ext

makeImageHTML :: Token (FilePath, FilePath) -> DepGenM' Text
makeImageHTML t = do
  (thumbnail, actual) <- untupleDepGenM t
  appendTexts
    (inject "<p><a href=\"")
    (appendTexts
      (toText actual)
      (appendTexts
        (inject "\"><img src=\"")
        (appendTexts
          (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 FilePath -> Token Template -> Token FilePath -> Token FilePath -> DepGenM ()
handleRecipeDir inputDir outputDir template indexName name = do
  dir <- joinPaths inputDir name
  recipeDirOut <- joinPaths outputDir name
  makeDir recipeDirOut
  dirContents <- listDirectory dir
  areImageFilenames <- mapDepGenM (hasExtension $ inject ["jpg"]) dirContents
  imageFilenames <- filterDepGenM areImageFilenames 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)
  htmlBodyBase <- runPandoc $ readTextFile $ joinPaths dir $ inject "ret.md"
  htmlBodyImages <- mapDepGenM makeImageHTML $ zipDepGenM thumbnailImageFilenames imageFilenames
  imagesHtml <- concatTexts htmlBodyImages
  htmlBody <- appendTexts htmlBodyBase imagesHtml
  html <- applyTemplate template htmlBody
  saveFile html $ joinPaths recipeDirOut indexName

generateSite :: DepGenM ()
generateSite = do
  outputDir <- inject "site"
  makeDir outputDir
  recipesDir <- inject "retter"
  outputRecipesDir <- joinPaths outputDir recipesDir
  makeDir outputRecipesDir
  template <- makeTemplate (readTextFile (inject "template.html")) (inject "CONTENT")
  indexName <- inject "index.html"
  dirNames <- listDirectory recipesDir
  dirPaths <- mapDepGenM (joinPaths recipesDir) dirNames
  dirPathsAreSubdirs <- mapDepGenM isDirectory dirPaths
  dirNames' <- filterDepGenM dirPathsAreSubdirs dirNames
  mapDepGenM_ (handleRecipeDir recipesDir outputRecipesDir template indexName) dirNames'
  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
  fontsPathsAreSubdirs <- mapDepGenM isDirectory fontsPaths
  fontsPaths' <- filterDepGenM fontsPathsAreSubdirs 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
  mask <- mapDepGenM (hasExtension $ inject ["woff2", "css"]) paths
  paths' <- filterDepGenM mask paths
  mapDepGenM_ (\p -> copyFile p (joinPaths outputDir p)) paths'