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 &raquo;" next
      ++ link "prev-link" "&laquo; 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 })