muon-0.1.0.8: src/Post.hs

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

import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.String.Utils as S
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 Data.Char
import Site
import Control.Monad
import Constant

postPath = "posts/"

replace :: String -> String -> T.Text -> T.Text
replace a b c = T.pack $ S.replace a b (T.unpack c)

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)
    return $ maybe (newSTMP "post.st not found")
                   id
                   (getStringTemplate "post" templates)

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

renderPostT :: Post -> IO T.Text
renderPostT p = do
    template <- postTemplate
    site <- readSite
    return $ renderPost site template p

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

makePost :: [T.Text] -> Post
makePost l = let a = T.append in Post { title  = head l
                  , link = "/" `a` (replace "-" "/" (l !! 1))
                           `a` "/" `a` linkify (head l)
                  , date =  l !! 1
                  , comment = l !! 2
                  , content = extractContent l
                  }

extractContent :: [T.Text] -> T.Text
extractContent lines = TL.toStrict
                 $ renderHtml
                 $ markdown def
                 $ TL.fromStrict
                 $ T.unlines
                 $ drop 3 lines

getPost :: FilePath -> IO Post
getPost n = T.readFile n >>= (return . makePost . T.lines)

getNames :: IO [FilePath]
getNames = do
    d <- globDir [compile "*.post"] postPath
    return $ (sort . head . fst) d

linkify :: T.Text -> T.Text
linkify s = T.filter (\x -> isAlphaNum x || x == '-')
          $ T.map toLower
          $ replace " " "-" s

writePosts :: [Post] -> IO ()
writePosts ps = mapM_ writePost ps

writePost :: Post -> IO ()
writePost p = do
    let a = T.append
    let d = (replace "-" "/" $ date p) `a` "/" `a` (linkify $ title p)
    mkdir $ sitePath ++ (T.unpack d)
    c <- renderPostT p
    T.writeFile (sitePath ++ (T.unpack d) ++ "/index.html") (T.append "\n" c)

getAllPosts :: IO [Post]
getAllPosts = getNames >>= mapM getPost

getAllExtracts :: IO [T.Text]
getAllExtracts = getAllPosts >>= (return . (map makeExtract))

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