mathblog-0.5: src/Main.hs
module Main where
import Control.Applicative
import Control.Monad
import Control.Concurrent
import Data.Maybe
import System.IO
import System.Exit
import System.Directory
import System.FilePath
import Data.Time.LocalTime
import qualified Text.Pandoc as Pandoc
import qualified MB.Config as Config
import MB.Templates
( loadTemplate
, renderTemplate
)
import MB.Processing
import MB.Util
( copyTree
, toLocalTime
, rssModificationTime
, loadPostIndex
, anyChanges
, serializePostIndex
, summarizeChanges
)
import MB.Types
import qualified MB.Files as Files
import Paths_mathblog
( getDataFileName
)
import MB.Startup
( StartupConfig(..)
, dataDirectory
, listenMode
, startupConfigFromEnv
, forceRegeneration
, initDataDirectory
)
import MB.Gnuplot
import MB.Tikz
import MB.Mathjax
import MB.Gladtex
defaultConfigFilename :: String
defaultConfigFilename = "blog.cfg"
skelDir :: IO FilePath
skelDir = getDataFileName "skel"
commonTemplateAttrs :: Blog -> [(String, String)]
commonTemplateAttrs blog =
[ ( "baseUrl", baseUrl blog )
, ( "title", title blog )
, ( "authorName", authorName blog )
, ( "authorEmail", authorEmail blog )
, ( "extraPageHead", extraPageHead blog )
]
extraPageHead :: Blog -> String
extraPageHead b = concat $ catMaybes $ pageHead <$> processors b
fillTemplate :: Blog -> Template -> [(String, String)] -> String
fillTemplate blog t attrs = renderTemplate attrs' t
where attrs' = commonTemplateAttrs blog ++ attrs
writeTemplate :: Blog -> Handle -> Template -> [(String, String)] -> IO ()
writeTemplate blog h t attrs = hPutStr h $ fillTemplate blog t attrs
writePost :: Blog -> Handle -> Post -> IO ()
writePost blog h post = do
let writerOpts = getWriterOptions blog Pandoc.defaultWriterOptions
created <- postModificationString post
hPutStr h $ "<h1>" ++ getPostTitle blog post BlogPost ++ "</h1>"
hPutStr h $ "<span class=\"post-created\">Posted " ++ created ++ "</span>"
hPutStr h $ Pandoc.writeHtmlString writerOpts (postAst post)
buildLinks :: Blog -> Maybe Post -> Maybe Post -> String
buildLinks _blog prev next =
"<div id=\"prev-next-links\">"
++ link "next-link" "older »" next
++ link "prev-link" "« newer" prev
++ "</div>"
where
link cls name Nothing =
"<span class=\"" ++ cls ++ "-subdued\">" ++ name ++ "</span>"
link cls name (Just p) =
"<a class=\"" ++ cls ++ "\" href=\"" ++ Files.postUrl p ++
"\">" ++ name ++ "</a>"
jsInfo :: Post -> String
jsInfo post =
"<script type=\"text/javascript\">\n" ++
"Blog = {\n" ++
" pageName: " ++ show (Files.postBaseName post) ++
"\n" ++
"};\n" ++
"</script>\n"
buildPage :: Handle -> Blog -> String -> Maybe String -> IO ()
buildPage h blog content extraTitle = do
eTmpl <- loadTemplate $ Files.pageTemplatePath blog
case eTmpl of
Left msg -> putStrLn msg >> exitFailure
Right tmpl ->
do
let attrs = [ ("content", content)
] ++ maybe [] (\t -> [("extraTitle", t)]) extraTitle
writeTemplate blog h tmpl attrs
hClose h
buildPost :: Handle -> Blog -> Post -> (Maybe Post, Maybe Post) -> IO ()
buildPost h blog post prevNext = do
eTmpl <- loadTemplate $ Files.postTemplatePath blog
case eTmpl of
Left msg -> putStrLn msg >> exitFailure
Right tmpl ->
do
html <- readFile $ Files.postIntermediateHtml blog post
let attrs = [ ("post", html)
, ("nextPrevLinks", uncurry (buildLinks blog) prevNext)
, ("jsInfo", jsInfo post)
]
let out = (fillTemplate blog tmpl attrs)
buildPage h blog out $ Just $ getRawPostTitle blog post
generatePost :: Blog -> Post -> ChangeSummary -> IO ()
generatePost blog post summary = do
let finalHtml = Files.postIntermediateHtml blog post
generate = (postFilename post `elem` (postsChanged summary))
|| configChanged summary
when generate $ do
putStrLn $ "Rendering " ++ Files.postBaseName post
newPost <- applyPreProcessors blog post
h <- openFile finalHtml WriteMode
writePost blog h newPost
hClose h
applyPostProcessors blog finalHtml BlogPost
generatePosts :: Blog -> ChangeSummary -> IO ()
generatePosts blog summary = do
let numRegenerated = if configChanged summary
then length $ blogPosts blog
else length $ postsChanged summary
when (numRegenerated > 0) $ putStrLn $ "Rendering " ++ (show numRegenerated) ++ " post(s)..."
let n = length posts
posts = blogPosts blog
forM_ (zip posts [0..]) $ \(p, i) ->
do
let prevPost = if i == 0 then Nothing else Just (posts !! (i - 1))
nextPost = if i == n - 1 then Nothing else Just (posts !! (i + 1))
generatePost blog p summary
h <- openFile (Files.postFinalHtml blog p) WriteMode
buildPost h blog p (prevPost, nextPost)
hClose h
buildIndexPage :: Blog -> IO ()
buildIndexPage blog = do
let src = Files.postFinalHtml blog post
index = Files.indexHtml blog
post = head $ blogPosts blog
copyFile src index
postModificationString :: Post -> IO String
postModificationString p = do
tz <- getCurrentTimeZone
localTime <- toLocalTime $ postModificationTime p
return $ show localTime ++ " " ++ timeZoneName tz
generatePostList :: Blog -> IO ()
generatePostList blog = do
-- For each post in the order they were given, extract the
-- unrendered title and construct an htex document. Then render it
-- to the listing location.
entries <- forM (blogPosts blog) $ \p ->
do
created <- postModificationString p
return $ concat [ "<div class=\"listing-entry\"><span class=\"post-title\">"
, "<a href=\"" ++ Files.postUrl p ++ "\">"
, getPostTitle blog p Index
, "</a></span><span class=\"post-created\">Posted "
, created
, "</span></div>\n"
]
let content = "<div id=\"all-posts\">" ++ concat entries ++ "</div>"
h <- openFile (Files.listHtml blog) WriteMode
buildPage h blog content Nothing
hClose h
applyPostProcessors blog (Files.listHtml blog) Index
rssItem :: Blog -> Post -> String
rssItem blog p =
concat [ "<item>"
, "<title>" ++ getRawPostTitle blog p ++ "</title>\n"
, "<link>" ++ baseUrl blog ++ Files.postUrl p ++ "</link>\n"
, "<pubDate>" ++ rssModificationTime p ++ "</pubDate>\n"
, "<guid>" ++ baseUrl blog ++ Files.postUrl p ++ "</guid>\n"
, "</item>\n"
]
generateRssFeed :: Blog -> IO ()
generateRssFeed blog = do
h <- openFile (Files.rssXml blog) WriteMode
eTmpl <- loadTemplate $ Files.rssTemplatePath blog
case eTmpl of
Left msg -> putStrLn msg >> exitFailure
Right tmpl ->
do
let items = map (rssItem blog) $ blogPosts blog
itemStr = concat items
attrs = [ ("items", itemStr)
]
writeTemplate blog h tmpl attrs
hClose h
initializeDataDir :: FilePath -> IO ()
initializeDataDir dir = do
existsBase <- doesDirectoryExist dir
existsConfig <- doesFileExist $ dir </> defaultConfigFilename
dataDir <- skelDir
when (not existsBase || not existsConfig) $ do
putStrLn $ "Setting up data directory using skeleton: " ++ dataDir
when (not existsBase) $ createDirectory dir
copyTree dataDir dir
when existsConfig $
putStrLn $ "Data directory already initialized; found " ++
(dir </> defaultConfigFilename)
ensureDirs :: Blog -> IO ()
ensureDirs blog = do
let dirs = [ postSourceDir
, htmlDir
, assetDir
, postHtmlDir
, postIntermediateDir
, imageDir
, templateDir
, htmlTempDir
, eqPreamblesDir
]
forM_ (dirs <*> pure blog) $ \d ->
do
exists <- doesDirectoryExist d
when (not exists) $ createDirectory d
scanForChanges :: IO Bool -> IO ()
scanForChanges act = do
scan
where
scan = do
didWork <- act
when didWork $ putStrLn ""
threadDelay $ 1 * 1000 * 1000
scan
mathBackends :: [(String, Processor)]
mathBackends =
[ ("gladtex", gladtexProcessor)
, ("mathjax", mathjaxProcessor)
]
eqBackends :: [(String, Processor)]
eqBackends =
[ ("gnuplot", gnuplotProcessor)
, ("tikz", tikzProcessor)
]
mkBlog :: StartupConfig -> IO Blog
mkBlog conf = do
let base = dataDirectory conf
configFile = base </> (configFilePath conf)
e <- doesFileExist configFile
when (not e) $ do
putStrLn $ "Configuration file " ++ configFile ++ " not found"
exitFailure
let requiredValues = [ "baseUrl"
, "title"
, "authorName"
, "authorEmail"
]
cfg <- Config.readConfig configFile requiredValues
let Just cfg_baseUrl = lookup "baseUrl" cfg
Just cfg_title = lookup "title" cfg
Just cfg_authorName = lookup "authorName" cfg
Just cfg_authorEmail = lookup "authorEmail" cfg
-- Load blog posts from disk
let postSrcDir = base </> "posts"
allPosts <- loadPostIndex postSrcDir
let requestedMathBackend = lookup "mathBackend" cfg
mathBackend = case requestedMathBackend of
Nothing -> mathjaxProcessor
Just b -> case lookup b mathBackends of
Nothing -> error $ "Unsupported math backend " ++ show b
++ "; valid choices are "
++ (show $ fst <$> mathBackends)
Just proc -> proc
requestedEqBackend = lookup "eqBackend" cfg
eqBackend = case requestedEqBackend of
Nothing -> gnuplotProcessor
Just b -> case lookup b eqBackends of
Nothing -> error $ "Unsupported equation backend " ++ show b
++ "; valid choices are "
++ (show $ fst <$> eqBackends)
Just proc -> proc
procs = [eqBackend, mathBackend]
let html = htmlOutputDirectory conf
b = Blog { baseDir = base
, postSourceDir = postSrcDir
, htmlDir = html
, assetDir = base </> "assets"
, postHtmlDir = html </> "posts"
, postIntermediateDir = base </> "generated"
, imageDir = html </> "generated-images"
, templateDir = base </> "templates"
, htmlTempDir = base </> "tmp"
, baseUrl = cfg_baseUrl
, title = cfg_title
, authorName = cfg_authorName
, authorEmail = cfg_authorEmail
, eqPreamblesDir = base </> "eq-preambles"
, configPath = configFile
, blogPosts = allPosts
, processors = procs
}
ensureDirs b
return b
installAssets :: Blog -> IO ()
installAssets blog = do
let ad = assetDir blog
-- For each file and directory in assets/, copy it to the output
-- directory.
entries <- filter (not . flip elem [".", ".."]) <$> getDirectoryContents ad
dirs <- filterM doesDirectoryExist $ map (ad </>) entries
files <- filterM doesFileExist $ map (ad </>) entries
forM_ dirs $ \d -> copyTree d (htmlDir blog </> (takeBaseName d))
forM_ files $ \f -> copyFile f (htmlDir blog)
regenerateContent :: StartupConfig -> IO Bool
regenerateContent conf = do
blog <- mkBlog conf
summary <- summarizeChanges blog (forceRegeneration conf)
case anyChanges summary of
False -> return False
True -> do
putStrLn $ "Blog directory: " ++ baseDir blog
putStrLn $ "Config file: " ++ configFilePath conf
when (configChanged summary) $
putStrLn "Configuration file changed; regenerating all content."
when (templatesChanged summary) $
putStrLn "Templates changed; regenerating accordingly."
when (not $ null $ postsChanged summary) $
do
putStrLn "Posts changed:"
forM_ (postsChanged summary) $ \n -> putStrLn $ " " ++ n
when (postIndexChanged summary) $
putStrLn "Post index changed; regenerating next/previous links."
when (assetsChanged summary) $
do
putStrLn "Assets changed; reinstalling."
installAssets blog
generatePosts blog summary
buildIndexPage blog
generatePostList blog
generateRssFeed blog
writeFile (Files.postIndex blog) $
serializePostIndex $ blogPosts blog
putStrLn "Done."
return True
main :: IO ()
main = do
conf <- startupConfigFromEnv
let dir = dataDirectory conf
when (initDataDirectory conf) $ initializeDataDir dir
case listenMode conf of
False -> do
didWork <- regenerateContent conf
when (not didWork) $ putStrLn "No changes found!"
True -> do
putStrLn $ "Waiting for changes in " ++ (dataDirectory conf) ++ " ..."
scanForChanges
(regenerateContent $ conf { forceRegeneration = False })