Types.hs

module MB.Types
    ( Blog(..)
    , StartupConfig(..)
    , BlogM
    , GenEvent(..)
    , GenState(..)
    , Post(..)
    , Template
    , ChangeSummary(..)
    , Page(..)
    , Processor(..)
    , RenderCause(..)
    , BlogInputFS(..)
    , BlogOutputFS(..)
    , BlogInputFSState(..)
    , nullProcessor
    , noChanges
    , theBlog
    , theConfig
    , notify
    , runBlogM
    , blogOutputFS
    , blogInputFS
    )
where
import Control.Concurrent.Chan
import Control.Monad.Reader
import Data.Time.Clock (UTCTime)
import Data.Monoid
import Data.List (nub)
import System.FilePath ((</>))
import Network.Socket (HostName, PortNumber)
import qualified Text.Pandoc as Pandoc
import Text.StringTemplate
    ( StringTemplate
    )

data StartupConfig = StartupConfig { dataDirectory :: FilePath
                                   , initDataDirectory :: Bool
                                   , forceRegeneration :: Bool
                                   , htmlOutputDirectory :: FilePath
                                   , configFilePath :: FilePath
                                   , listenAddr :: Maybe (HostName, PortNumber)
                                   , overrideBaseUrl :: Maybe String
                                   }
                     deriving (Show, Eq)

blogOutputFS :: StartupConfig -> BlogOutputFS
blogOutputFS c =
    let base = htmlOutputDirectory c
        images = base </> "generated-images"
        posts = base </> "posts"
    in BlogOutputFS { ofsBaseDir = base
                    , ofsPostHtmlDir = posts
                    , ofsImageDir = images
                    , ofsHtmlTempDir = base </> "tmp"
                    , ofsImagePath = \fn -> images </> fn
                    , ofsIndexHtml = base </> "index.html"
                    , ofsRssXml = base </> "feed.xml"
                    , ofsListHtml = posts </> "index.html"
                    , ofsPostFinalHtml = \p -> posts </> postHtmlFilename p
                    }

blogInputFS :: StartupConfig -> BlogInputFS
blogInputFS c =
    let base = dataDirectory c
        templates = base </> "templates"
        posts = base </> "posts"
    in BlogInputFS { ifsBaseDir = base
                   , ifsPostSourceDir = posts
                   , ifsTemplateDir = templates
                   , ifsPostIndexPath = posts </> "posts-index"
                   , ifsConfigPath = base </> "blog.cfg"
                   , ifsAssetDir = base </> "assets"
                   , ifsPageTemplatePath = templates </> "pageTemplate.html"
                   , ifsListTemplatePath = templates </> "listTemplate.html"
                   , ifsPostTemplatePath = templates </> "postTemplate.html"
                   , ifsRssTemplatePath = templates </> "rssTemplate.xml"
                   }

data GenState =
    GenState { stBlog :: Blog
             , stChan :: Chan GenEvent
             , stConfig :: StartupConfig
             }

data GenEvent = PostRender Post [RenderCause]
              | Finished

data RenderCause = Config
                 | PostIndex
                 | Template
                 | PostModified
                 | Forced
                   deriving (Eq, Show)

type BlogM a = ReaderT GenState IO a

theBlog :: BlogM Blog
theBlog = asks stBlog

theConfig :: BlogM StartupConfig
theConfig = asks stConfig

notify :: GenEvent -> BlogM ()
notify ev = do
  ch <- asks stChan
  liftIO $ writeChan ch ev

runBlogM :: Blog -> Chan GenEvent -> StartupConfig -> BlogM a -> IO a
runBlogM b ch conf act = runReaderT act (GenState b ch conf)

type Template = StringTemplate String

data BlogInputFS =
 BlogInputFS { ifsBaseDir :: FilePath
             , ifsPostSourceDir :: FilePath
             , ifsAssetDir :: FilePath
             , ifsTemplateDir :: FilePath
             , ifsConfigPath :: FilePath
             , ifsPostIndexPath :: FilePath
             , ifsPageTemplatePath :: FilePath
             , ifsListTemplatePath :: FilePath
             , ifsPostTemplatePath :: FilePath
             , ifsRssTemplatePath :: FilePath
             }

data BlogOutputFS =
    BlogOutputFS { ofsBaseDir :: FilePath
                 , ofsPostHtmlDir :: FilePath
                 , ofsImageDir :: FilePath
                 , ofsHtmlTempDir :: FilePath
                 , ofsImagePath :: String -> FilePath
                 , ofsIndexHtml :: FilePath
                 , ofsRssXml :: FilePath
                 , ofsListHtml :: FilePath
                 , ofsPostFinalHtml :: Post -> FilePath
                 }

data BlogInputFSState =
    BlogInputFSState { ifsPostIndexMTime :: UTCTime
                     , ifsConfigMTime :: UTCTime
                     , ifsBaselineMTime :: UTCTime
                     , ifsTemplateMTime :: UTCTime
                     }


data Blog = Blog { inputFS :: BlogInputFS
                 , outputFS :: BlogOutputFS
                 , inputFSState :: BlogInputFSState
                 , baseUrl :: String
                 , title :: String
                 , authorName :: String
                 , authorEmail :: String
                 , blogPosts :: [Post]
                 , processors :: [Processor]
                 }

data Post = Post { postTitle :: [Pandoc.Inline]
                 , postPath :: String
                 , postFilename :: String
                 , postModificationTime :: UTCTime
                 , postModificationString :: String
                 , postAst :: Pandoc.Pandoc
                 , postTeXMacros :: String
                 , postAuthors :: [String]
                 , postDate :: Maybe String
                 , postBaseName :: String
                 , postUrl :: String
                 , postHtmlFilename :: String
                 }
            deriving (Eq)

data Page = BlogPost
          | Index

data Processor =
    Processor { applyWriterOptions :: Maybe (Pandoc.WriterOptions -> Pandoc.WriterOptions)
              , preProcessPost :: Maybe (Post -> BlogM Post)
              , postProcessPost :: Maybe (FilePath -> Page -> BlogM ())
              , pageHead :: Maybe String
              , buildPostTitle :: Maybe (Page -> [Pandoc.Inline] -> [Pandoc.Inline])
              , rawPostTitle :: Maybe ([Pandoc.Inline] -> String)
              , checkDataDir :: Maybe (BlogM ())
              , installAssets :: Maybe (BlogM ())
              }

nullProcessor :: Processor
nullProcessor =
    Processor Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

-- Summarize changes in files so we know what to do during the
-- regeneration phase.  postsChanged and configChanged are the primary
-- measurements, but knowing whether other metadata files changed
-- (like templates) is useful for the "listen" mode of mb.
data ChangeSummary =
    ChangeSummary { postsChanged :: [String]
                  , configChanged :: Bool
                  , templatesChanged :: [FilePath]
                  , postIndexChanged :: Bool
                  , assetsChanged :: [FilePath]
                  }
    deriving (Show)

noChanges :: ChangeSummary
noChanges = ChangeSummary [] False [] False []

instance Monoid ChangeSummary where
    mempty = noChanges
    a `mappend` b =
        ChangeSummary { postsChanged = nub $ postsChanged a ++ postsChanged b
                      , configChanged = configChanged a || configChanged b
                      , templatesChanged = templatesChanged a `mappend` templatesChanged b
                      , postIndexChanged = postIndexChanged a || postIndexChanged b
                      , assetsChanged = assetsChanged a `mappend` assetsChanged b
                      }