blogination (empty) → 0.0

raw patch · 6 files changed

+222/−0 lines, 6 filesdep +ConfigFiledep +basedep +directorysetup-changed

Dependencies added: ConfigFile, base, directory, filepath, haskell98, higherorder, highlighting-kate, mtl, old-time, pandoc, xhtml

Files

• LICENSE +0/−0
• Setup.lhs +3/−0
• blogination.cabal +23/−0
• executable/Main.hs +29/−0
• library/Text/Blogination.hs +160/−0
• sample-blog.conf +7/−0

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,23 @@+name:                blogination+version:             0.0+synopsis:            Very simple static blog software+description:         Blogination reads files written in markdown and outputs xhtml. Supports syntax highlighting. Philosophy is simplicity. Can be used as a library, in a web application for example. Intended use is a simple commandline program to run after changes are made. Ideally use darcs or git with it.+category:            Web+license:             BSD3+license-file:        LICENSE+author:              Chris Done <chrisdone@gmail.com>+maintainer:          chrisdone@gmail.com+build-Depends:       base+cabal-Version:       >= 1.2+build-type:          Simple+Data-Files: sample-blog.conf++library+  build-depends: base,filepath,directory,pandoc,xhtml,highlighting-kate,higherorder,mtl+  exposed-modules: Text.Blogination+  hs-source-dirs: library/++executable blogination+  build-depends: base,ConfigFile,haskell98,old-time+  main-is: Main.hs+  hs-source-dirs: . library/ executable/

@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleInstances #-}+import Control.Applicative+import Control.Monad+import Control.Monad.Error+import System+import Text.Blogination+import qualified Data.ConfigFile as C++main = do+  args <- getArgs+  case args of+    (conf:k) -> do +       conf <- getConf conf+       case conf of+         Left err -> error $ show err+         Right blog -> runBloginator buildBlog blog { blogForce = not $ null k }+    _ -> getConf "blog.conf" >>= either (error . show) (runBloginator buildBlog)++instance Monad m => Applicative (ErrorT C.CPError m) where+    pure = return; (<*>) = ap++getConf :: FilePath -> IO (Either (C.CPErrorData,String) Blog)+getConf filePath = runErrorT $ do+  config <- join $ liftIO $ C.readfile C.emptyCP filePath+  let get = C.get config "BLOG"+  Blog <$> get "name" <*> get "root"+       <*> (read <$> get "css") <*> get "entries" <*> get "html"+       <*> get "author"+       <*> (return False)

@@ -0,0 +1,160 @@+{-# LANGUAGE RecordWildCards #-}+module Text.Blogination +    (Blog(..)+    ,Blogination+    ,runBloginator+    ,buildBlog+    ,ensureProperState+    ,renderIndex+    ,renderEntries+    ,pageToHtml+    ,highlight)+    where++import Control.Arrow+import Control.Monad.State+import Control.Monad.Error+import Data.Char hiding (Space)+import Data.List.Higher+import Data.Maybe+import Text.Highlighting.Kate+import Text.Pandoc+import Text.Printf+import Text.XHtml.Strict+import System.Directory+import System.FilePath+import System.Time++data Blog = Blog+    { blogName     :: String -- e.g. Chris Done's Blog+    , blogRoot     :: String -- /blog+    , blogCSS      :: [String] -- e.g. ["style.css","highlight.css"]+    , blogEntries  :: FilePath+    , blogHtml     :: FilePath+    , blogAuthor   :: String+    , blogForce    :: Bool+    } deriving (Read,Show)++type Blogination = ErrorT String (StateT Blog IO)++runBloginator :: Blogination a -> Blog -> IO (Either String a)+runBloginator m blog = evalStateT (runErrorT m) blog++buildBlog :: Blogination ()+buildBlog = do ensureProperState+               anyChanges <- renderEntries+               when anyChanges renderIndex++renderIndex :: Blogination ()+renderIndex = do+  blog@Blog{..} <- lift get+  links <- mapM getEntryLink =<< getEntryNames+  let html = toHtml [title,name,menu]+      title = thetitle << blogName+      name = h1 << blogName+      menu = ulist << map ((li<<) . showLink) links+  liftIO $ writeFile "index.html" $ showHtml html+      where showLink (url,title) = hotlink url << title++getEntryLink :: FilePath -> Blogination (URL,String)+getEntryLink path = do+  blog@Blog{..} <- lift get+  liftIO $ do+    contents <- readFile (blogEntries</>path)+    return (blogRoot++"/"++blogHtml++"/"++path++".html"+           ,getTitle $ read $ contents)+        where read = readMarkdown defaultParserState++renderEntries :: Blogination Bool+renderEntries = do+  blog@Blog{..} <- lift get+  names <- getEntryNames+  let times dir = liftIO $ mapM (getModificationTime' . dir) names+  entryTimes <- times (blogEntries</>)+  htmlTimes <- times ((blogHtml</>).(++".html"))+  let updated = catMaybes $ zipWith compare names $ zip entryTimes htmlTimes+      compare name (entry,html) | entry > html = Just name+                                | otherwise    = Nothing+      toChange | blogForce = names+               | otherwise = updated+  mapM_ renderEntry toChange+  return $ not $ null toChange++getModificationTime' :: FilePath -> IO (Maybe ClockTime)+getModificationTime' path = do+  exists <- doesFileExist path+  if exists+     then Just `fmap` getModificationTime path+     else return Nothing++renderEntry :: FilePath -> Blogination ()+renderEntry path = do+  blog@Blog{..} <- lift get+  liftIO $ do+    contents <- readFile (blogEntries</>path)+    writeFile (blogHtml</>path++".html") $ showHtml $ pageToHtml blog contents++getEntryNames :: Blogination [FilePath]+getEntryNames = do+  Blog{..} <- lift get+  return . clean =<< liftIO (getDirectoryContents blogEntries) +    where clean = reverse . sort . filter (not . all (=='.'))++ensureProperState :: Blogination ()+ensureProperState = do+  Blog{..} <- lift get+  entries <- liftIO $ doesDirectoryExist blogEntries+  when (not entries) $ do +    throwError $ printf "Blog entries directory \"%s\" does not exist."+                        blogEntries+    return ()+  liftIO $ createDirectoryIfMissing False blogHtml++pageToHtml :: Blog -> String -> Html+pageToHtml blog = html . second write . (getTitle &&& highlight) . read where+    read = readMarkdown defaultParserState+    write = writeHtml defaultWriterOptions+    html = template blog++template :: Blog -> (String,Html) -> Html+template Blog{..} (title,html) = toHtml [head,thebody] where+    head = header << [toHtml $ map style blogCSS+                     ,meta ! [httpequiv "Content-Type"+                             ,content "text/html; charset=utf-8"]+                     ,thetitle << title]+    thebody = body << [back,hr,html,hr,back]+    back = toHtml $ p << hotlink blogRoot << ("« Back to " ++ blogName)+    style css = thelink ! [rel "stylesheet",href (blogRoot++"/"++css)]+                << noHtml++getTitle :: Pandoc -> String+getTitle (Pandoc meta blocks) = title blocks where+    title = list "" head . catMaybes . map getHeading+    getHeading (Header 1 parts) = Just $ join $ map getPart parts+    getHeading _ = Nothing+    getPart (Str str) = str+    getPart Space = " "+    getPart _ = " "++highlight :: Pandoc -> Pandoc+highlight (Pandoc meta blocks) = Pandoc meta newblocks where+    newblocks = map tryHighlight blocks+    tryHighlight (CodeBlock opts ('$':rest))+        | take 1 rest == "$" = CodeBlock opts rest+        | otherwise = +            case highlightOpts ('$':rest) of+              Just (lang,code) -> highlightWith lang code+              Nothing          -> CodeBlock opts ('$':rest)+    tryHighlight other = other++highlightOpts :: String -> Maybe (String,String)+highlightOpts = langAndCode . break isSpace where+    langAndCode ('$':lang,code) = Just (lang,drop 1 code)+    langAndCode _               = Nothing++highlightWith :: String -> String -> Block+highlightWith lang code = RawHtml $ showHtml html where+    html = either (const def) format highlight+    format = formatAsXHtml [] lang+    highlight = highlightAs lang code+    def = pre << code

@@ -0,0 +1,7 @@+[BLOG]+name = My blog+author = Alan Turing+root = /blog+css = ["blog.css","highlight.css"]+entries = entries+html = html