Haggis.hs

module Text.Haggis (
  -- * Site generation entry point
  buildSite
  ) where

import qualified Data.ByteString.Lazy as BS
import Data.Either
import Data.Function
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Time.Calendar

import System.Posix.Files.ByteString
import System.FilePath
import System.FilePath.Find
import System.Directory

import Text.XmlHtml

import Text.Haggis.Comments
import Text.Haggis.Config
import Text.Haggis.Parse
import Text.Haggis.RSS
import Text.Haggis.Types
import Text.Haggis.Utils
import Text.Hquery

buildSite :: FilePath -> FilePath -> IO ()
buildSite src tgt = do
  templates <- readTemplates $ src </> "templates"
  config <- parseConfig (src </> "haggis.conf") templates
  comments <- getComments config
  actions <- collectSiteElements (src </> "src") tgt comments
  let (raws, pages) = partitionEithers actions
  readPages <- sequence pages
  let multiPages = generateAggregates readPages
      specialPages = generateSpecial config multiPages
      allPages = concat [readPages, specialPages]
  sequence_ raws
  generateRSS config readPages tgt
  writeSite allPages multiPages config tgt

writeSite :: [Page] -> [MultiPage] -> HaggisConfig -> FilePath -> IO ()
writeSite ps mps config out = do
  sequence_ $ map writePage ps
  sequence_ $ map writeMultiPage mps
  where
    wrapper = getBindSpecial config mps $ root (siteTemplates config)
    writeThing fp title ns = do
      let xform = hq "#content *" (Group ns) . hq "title *" title
          html = xform $ wrapper
          path = out </> fp
      ensureDirExists path
      BS.writeFile path $ renderHtml html
    writePage :: Page -> IO ()
    writePage p =
      let content = getBindPage config p $ single (siteTemplates config)
      in writeThing (pagePath p) (pageTitle p) content
    writeMultiPage :: MultiPage -> IO ()
    writeMultiPage mp =
      let xform = hq ".page *" $ map (getBindPage config) $ singlePages mp
          content = xform $ multiple (siteTemplates config)
          path = mpTypeToPath $ multiPageType mp
      in writeThing path (mpTypeToTitle config $ multiPageType mp) content

ensureDirExists :: FilePath -> IO ()
ensureDirExists = createDirectoryIfMissing True . dropFileName

generateSpecial :: HaggisConfig -> [MultiPage] -> [Page]
generateSpecial config mps =
  let bind = getBindSpecial config mps
      archivesContent = bind (archivesTemplate $ siteTemplates config)
      archives = plainPage "Archives" "./archives/index.html" archivesContent
      tagsContent = bind (tagsTemplate $ siteTemplates config)
      tags = plainPage "Tags" "./tags/index.html" tagsContent
  in [archives, tags]
  where
    plainPage :: String -> FilePath -> [Node] -> Page
    plainPage title fp content = Page title Nothing [] Nothing fp [] content -- TODO: Support comments?

generateAggregates :: [Page] -> [MultiPage]
generateAggregates ps =
  let tagPages = buildMultiPages Tag tags
      indexPages = buildMultiPages DirIndex indexes
      yearPages = buildMultiPages id yearArchives
      monthPages = buildMultiPages id monthArchives
      rootIndex = MultiPage recent (DirIndex "./")
  in rootIndex : concat [tagPages, indexPages, yearPages, monthPages]
  where
    tags = mapAccum $ concatMap (\p -> zip (pageTags p) (repeat p)) ps
    indexes = let noroot = filter ((/=) "./" . dropFileName . pagePath) ps
              in mapAccum $ map (\p -> (dropFileName $ pagePath p, p)) noroot
    monthAndYearOf d = let (y, m, _) = toGregorian d in (y, Just m)
    yearOf d = let (y, _) = monthAndYearOf d in (y, Nothing)
    buildArchive f =
      mapAccum $ catMaybes $ map (\p -> fmap (\d -> (uncurry Archive $ f d, p)) $ pageDate p) ps
    yearArchives = buildArchive yearOf
    monthArchives = buildArchive monthAndYearOf
    buildMultiPages :: (a -> MultiPageType) -> M.Map a [Page] -> [MultiPage]
    buildMultiPages typeBuilder pm =
      map (\(name, pages) -> MultiPage pages $ typeBuilder name) $ M.toList pm
    recent = let hasDate = filter (isJust . pageDate) ps
             in take 10 $ reverse $ sortBy (compare `on` pageDate) hasDate

type Accum = [Either (IO ()) (IO Page)]
collectSiteElements ::
  FilePath ->
  FilePath ->
  (FilePath -> [Comment]) ->
  IO Accum
collectSiteElements src tgt comments = foldWithHandler
  ignoreExceptions
  always
  accumulate
  []
  src
  where
    accumulate :: Accum -> FileInfo -> Accum
    accumulate acc info = makeAction info : acc
    ignoreExceptions _ a _ = return a
    mkRelative :: FilePath -> FilePath
    mkRelative = makeRelative src
    makeAction :: FileInfo -> Either (IO ()) (IO Page)
    makeAction info | supported info = Right $ do
      let path = infoPath info
          rel = mkRelative path
          target = replaceExtension rel ".html"
          pageBuilder = parsePage path target
      pageBuilder $ comments rel
    makeAction info | isRegularFile $ infoStatus info = Left $ do
      let path = infoPath info
      let target = tgt </> mkRelative path
      ensureDirExists target
      copyFile path target
    makeAction _ = Left (return ()) -- TODO: follow symlinks?