muon-0.1.0.0: src/Post.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Post where

import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.StringTemplate
import Text.StringTemplate.GenericStandard
import Text.Blaze.Html.Renderer.Text
import Text.Markdown
import System.Directory
import System.FilePath.Glob
import Data.Typeable
import Data.Data
import Data.List
import Site
import Control.Monad
import Constant

postPath = "posts/" :: String

data Post = Post { title :: T.Text
                 , link :: T.Text
                 , date :: T.Text
                 , comment :: T.Text
                 , content :: T.Text
                 } deriving (Data, Typeable, Show)

postTemplate = do
    templates <- directoryGroup "templates" :: IO (STGroup T.Text)
    let Just t = getStringTemplate "post" templates
    return t

renderPost ::  StringTemplate T.Text -> Post -> T.Text
renderPost t p = render
               $ setAttribute "site" defaultSite
               $ setAttribute "post" p t

renderName ::  StringTemplate T.Text -> String -> IO T.Text
renderName t n = liftM (renderPost t) (getPost (0, n))

makeExtract ::  Post -> T.Text
makeExtract p = T.pack
                  $ "<h2>" ++ T.unpack (title p) ++ "</h2>"
                 ++ "<h3>" ++ T.unpack (date p) ++ "</h3>"
                 ++  unlines (take 25 $ lines $ T.unpack $ content p)
                 ++ "<br/><br/><a href=\'" ++ T.unpack (link p) ++ "\'>Read more...</a>"
                 ++ "</code></pre></li></ul></ol><hr/>"

makePost ::  (Int, [String]) -> Post
makePost l = Post { title  = T.pack $ head (snd l)
                  , link = T.pack $ "/post/" ++ show (fst l)
                  , date = T.pack $ snd l !! 1
                  , comment = T.pack $ snd l !! 2
                  , content = T.pack $ extractContent (snd l) }

extractContent ::  [String] -> String
extractContent l = TL.unpack
                 $ renderHtml
                 $ markdown def
                 $ TL.pack
                 $ unlines
                 $ drop 3 l

getPost ::  (Int, FilePath) -> IO Post
getPost n = do
    c <- readFile (snd n)
    return $ makePost (fst n, lines c)

getNames ::  IO [(Int, FilePath)]
getNames = do
    d <- globDir [compile "*.post"] postPath
    let l = (sort . head . fst) d
    return $ zip [1..(length l)] l

renderPosts ::  IO [T.Text]
renderPosts = do
    templates <- directoryGroup "templates" :: IO (STGroup T.Text)
    let Just t = getStringTemplate "post" templates
    ns <- getNames
    mapM (renderName t . snd) ns

writePosts ::  [T.Text] -> IO ()
writePosts ps = mapM_ writePost (zip [1..(length ps)] ps)

writePost ::  (Int, T.Text) -> IO ()
writePost p = do
    mkdir $ sitePath ++ "post"
    mkdir $ sitePath ++ "post/" ++ show (fst p)
    writeFile (sitePath ++ "post/" ++ show (fst p) ++ "/index.html") (T.unpack $ T.append "\n" $ snd p)

getAllPosts = do
    ns <- getNames
    mapM getPost ns

getAllExtracts = do
    ps <- getAllPosts
    return $ map makeExtract ps

generatePosts = renderPosts >>= writePosts >> putStrLn "Generated posts"