haggis 0.1.0.0 → 0.1.1.0

raw patch · 10 files changed

+319/−77 lines, 10 filesdep +HDBCdep +HDBC-sqlite3dep +MissingHdep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HDBC, HDBC-sqlite3, MissingH, convertible, network, rss

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• haggis.cabal +6/−4
• src/Text/Haggis.hs +29/−32
• src/Text/Haggis/Binders.hs +42/−22
• src/Text/Haggis/Comments.hs +74/−0
• src/Text/Haggis/Config.hs +58/−0
• src/Text/Haggis/Parse.hs +18/−16
• src/Text/Haggis/RSS.hs +32/−0
• src/Text/Haggis/Types.hs +37/−1
• src/Text/Haggis/Utils.hs +21/−0
• tools/haggis.hs +2/−2

@@ -1,5 +1,5 @@ name:                haggis-version:             0.1.0.0+version:             0.1.1.0 synopsis:            A static site generator with blogging/comments support homepage:            http://github.com/tych0/haggis license:             MIT@@ -22,12 +22,14 @@   build-depends: base ==4.*, filemanip >= 0.3, filepath >= 1.3,                  directory >= 1.1, unix >= 2.5, bytestring >= 0.9,                  blaze-builder >= 0.3, pandoc >= 1.10, pandoc-types >= 1.10,-                 xmlhtml >= 0.2, containers >= 0.4, hquery >= 0.1.0.2,+                 xmlhtml >= 0.2, containers >= 0.5, hquery >= 0.1.0.2,                  time >= 1.4, old-locale, parsec >= 3.1, split >= 0.2,-                 text >= 0.11+                 text >= 0.11, rss >= 3000.2, network >= 2.4, MissingH >= 1.2,+                 HDBC >= 2.3, HDBC-sqlite3 >= 2.3, convertible >= 1.0.11   hs-source-dirs: src   exposed-modules: Text.Haggis, Text.Haggis.Parse, Text.Haggis.Types,-                   Text.Haggis.Binders+                   Text.Haggis.Binders, Text.Haggis.RSS, Text.Haggis.Utils,+                   Text.Haggis.Config, Text.Haggis.Comments   ghc-options: -Wall  executable haggis

@@ -3,10 +3,6 @@   buildSite   ) where -import Blaze.ByteString.Builder--import Control.Applicative- import qualified Data.ByteString.Lazy as BS import Data.Either import Data.Function@@ -23,66 +19,66 @@ import Text.XmlHtml  import Text.Haggis.Binders+import Text.Haggis.Comments+import Text.Haggis.Config import Text.Haggis.Parse+import Text.Haggis.RSS import Text.Haggis.Types+import Text.Haggis.Utils import Text.Hquery -readTemplates :: FilePath -> IO SiteTemplates-readTemplates fp = SiteTemplates <$> readTemplate (fp </> "root.html")-                                 <*> readTemplate (fp </> "single.html")-                                 <*> readTemplate (fp </> "multiple.html")-                                 <*> readTemplate (fp </> "tags.html")-                                 <*> readTemplate (fp </> "archives.html")- buildSite :: FilePath -> FilePath -> IO () buildSite src tgt = do   templates <- readTemplates $ src </> "templates"-  actions <- collectSiteElements (src </> "src") tgt+  config <- parseConfig (src </> "haggis.conf") templates+  comments <- getComments config+  actions <- collectSiteElements (src </> "src") tgt comments   let (raws, pages) = partitionEithers actions   readPages <- sequence pages   let multiPages = generateAggregates readPages-      specialPages = generateSpecial templates multiPages+      specialPages = generateSpecial config multiPages       allPages = concat [readPages, specialPages]-  writeSite allPages multiPages templates tgt   sequence_ raws+  generateRSS config readPages tgt+  writeSite allPages multiPages config tgt -writeSite :: [Page] -> [MultiPage] -> SiteTemplates -> FilePath -> IO ()-writeSite ps mps templates out = do+writeSite :: [Page] -> [MultiPage] -> HaggisConfig -> FilePath -> IO ()+writeSite ps mps config out = do   sequence_ $ map writePage ps   sequence_ $ map writeMultiPage mps   where-    wrapper = bindSpecial mps $ root templates+    wrapper = bindSpecial config mps $ root (siteTemplates config)     writeThing fp title ns = do       let xform = hq "#content *" (Group ns) . hq "title *" title           html = xform $ wrapper           path = out </> fp       ensureDirExists path-      BS.writeFile path $ toLazyByteString $ renderHtmlFragment UTF8 html+      BS.writeFile path $ renderHtml html     writePage :: Page -> IO ()     writePage p =-      let content = bindPage p $ single templates+      let content = bindPage config p $ single (siteTemplates config)       in writeThing (pagePath p) (pageTitle p) content     writeMultiPage :: MultiPage -> IO ()     writeMultiPage mp =-      let xform = hq ".page *" $ map bindPage $ singlePages mp-          content = xform $ multiple templates+      let xform = hq ".page *" $ map (bindPage config) $ singlePages mp+          content = xform $ multiple (siteTemplates config)           path = mpTypeToPath $ multiPageType mp       in writeThing path (mpTypeToTitle $ multiPageType mp) content  ensureDirExists :: FilePath -> IO () ensureDirExists = createDirectoryIfMissing True . dropFileName -generateSpecial :: SiteTemplates -> [MultiPage] -> [Page]-generateSpecial templates mps =-  let bind = bindSpecial mps-      archivesContent = bind (archivesTemplate templates)+generateSpecial :: HaggisConfig -> [MultiPage] -> [Page]+generateSpecial config mps =+  let bind = bindSpecial config mps+      archivesContent = bind (archivesTemplate $ siteTemplates config)       archives = plainPage "Archives" "./archives/index.html" archivesContent-      tagsContent = bind (tagsTemplate templates)+      tagsContent = bind (tagsTemplate $ siteTemplates config)       tags = plainPage "Tags" "./tags/index.html" tagsContent   in [archives, tags]   where     plainPage :: String -> FilePath -> [Node] -> Page-    plainPage title fp content = Page title Nothing [] Nothing fp content+    plainPage title fp content = Page title Nothing [] Nothing fp [] content -- TODO: Support comments?  generateAggregates :: [Page] -> [MultiPage] generateAggregates ps =@@ -93,8 +89,6 @@       rootIndex = MultiPage recent (DirIndex "./")   in rootIndex : concat [tagPages, indexPages, yearPages, monthPages]   where-    mapAccum :: Ord a => [(a, b)] -> M.Map a [b]-    mapAccum = foldr (\(k,v) -> M.insertWith (++) k [v]) M.empty     tags = mapAccum $ concatMap (\p -> zip (pageTags p) (repeat p)) ps     indexes = let noroot = filter ((/=) "./" . dropFileName . pagePath) ps               in mapAccum $ map (\p -> (dropFileName $ pagePath p, p)) noroot@@ -114,8 +108,9 @@ collectSiteElements ::   FilePath ->   FilePath ->+  (FilePath -> [Comment]) ->   IO Accum-collectSiteElements src tgt = foldWithHandler+collectSiteElements src tgt comments = foldWithHandler   ignoreExceptions   always   accumulate@@ -130,8 +125,10 @@     makeAction :: FileInfo -> Either (IO ()) (IO Page)     makeAction info | supported info = Right $ do       let path = infoPath info-          target = replaceExtension (mkRelative path) ".html"-      parsePage path target+          rel = mkRelative path+          target = replaceExtension rel ".html"+          pageBuilder = parsePage path target+      pageBuilder $ comments rel     makeAction info | isRegularFile $ infoStatus info = Left $ do       let path = infoPath info       let target = tgt </> mkRelative path

@@ -5,45 +5,65 @@   -- * Bind the specified tag to an anchor.   bindTag,   -- * Bind the archives and tags.-  bindSpecial+  bindSpecial,+  bindComment   ) where  import Data.Either  import System.FilePath +import Text.Pandoc.Readers.Markdown+import Text.Pandoc.Options import Text.Haggis.Types+import Text.Haggis.Utils import Text.Hquery import Text.XmlHtml -bindPage :: Page -> [Node] -> [Node]-bindPage Page { pageTitle = title-              , pageTags = tags-              , pageDate = date-              , pagePath = path-              , pageContent = content-              } = hq ".title *" title .-                  (if null tags then hq ".tags" nothing else hq ".tag *" (map bindTag tags)) .-                  -- TODO: what if author but no date?-                  maybe (hq ".byline" nothing) (hq ".date *") (fmap show date) .-                  hq ".date *" (fmap show date) .-                  (hq ".content *" $ Group content) .-                  hq ".more [href]" ("/" </> path)+bindPage :: HaggisConfig -> Page -> [Node] -> [Node]+bindPage config Page { pageTitle = title+                     , pageAuthor = author+                     , pageTags = tags+                     , pageDate = date+                     , pagePath = path+                     , pageContent = content+                     , pageComments = comments+                     } =+  let bindTags = if null tags+                   then hq ".tags" nothing+                   else hq ".tag *" (map (bindTag config) tags)+      auth = maybe (defaultAuthor config) Just author+  in hq ".title *" title .+     bindTags .+     hq ".author *" auth .+     hq ".date *" (fmap show date) .+     (hq ".content *" $ Group content) .+     hq ".more [href]" (sitePath config </> path) .+     hq ".commentCount *" ((show . length) comments) .+     hq ".comment *" (map bindComment comments) -bindTag :: String -> [Node] -> [Node]-bindTag t = hq ".tag [href]" ("/" </> (mpTypeToPath $ Tag t)) .-            hq ".tag *" (t ++ ", ")+bindComment :: Comment -> [Node] -> [Node]+bindComment c = nameBind (commenterUrl c)+              . hq ".datetime *" (show (commentTime c))+              . hq ".payload *" (pandocToHtml (readMarkdown def (commentPayload c))) -bindSpecial :: [MultiPage] -> [Node] -> [Node]-bindSpecial mps = let (archives, tags) = bindAggregates-                  in hq ".tag" tags . hq ".archive *" archives   where+    nameBind (Just url) = hq ".name *" (commenterName c) . hq ".name [href]" url+    nameBind Nothing = hq ".name" (commenterName c)+bindTag :: HaggisConfig -> String -> [Node] -> [Node]+bindTag config t = hq "a [href]" (sitePath config </> (mpTypeToPath $ Tag t)) .+                   hq "a *" (t ++ ", ")++bindSpecial :: HaggisConfig -> [MultiPage] -> [Node] -> [Node]+bindSpecial config mps = let (archives, tags) = bindAggregates+                         in hq ".tag" tags . hq ".archive *" archives+  where     bindAggregates :: ([[Node] -> [Node]], [[Node] -> [Node]])     bindAggregates = let bind (MultiPage _ typ@(Archive y (Just m))) = Left $-                           hq "a [href]" ("/" </> mpTypeToPath typ) .+                           hq "a [href]" (sitePath config </> mpTypeToPath typ) .                            hq "a *" (show y ++ " - " ++ show m)                          bind (MultiPage xs typ@(Tag t)) = Right $-                           hq ".tag [href]" ("/" </> mpTypeToPath typ) .+                           hq ".tag [href]" (sitePath config </> mpTypeToPath typ) .                            hq ".tag *" (t ++ " (" ++ show (length xs) ++ "), ")                          bind _ = Left $ hq "*" nothing                      in partitionEithers $ map bind mps

@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}+module Text.Haggis.Comments (+  getComments,+  commentsEnabled,+  CommentException(..)+  ) where++import Control.Exception+import Control.Monad++import Database.HDBC+import Database.HDBC.Sqlite3+import Data.Convertible+import qualified Data.Map.Lazy as M+import Data.Maybe+import qualified Data.Traversable as T+import Data.Typeable++import Prelude hiding (catch)++import System.FilePath++import Text.Haggis.Types+import Text.Haggis.Utils++data CommentException = CommentException String deriving (Show, Typeable)+instance Exception CommentException++getComments :: HaggisConfig -> IO (FilePath -> [Comment])+getComments conf = do+  conn <- getConnection conf+  comments <- T.sequence (fmap queryComments conn)+  return $ \fp -> fromMaybe [] $ M.lookup (normalize fp) (fromMaybe M.empty comments)+  where+    -- Comments are stored in the database according to their path relative to+    -- the src/ directory in the tree, so we normalize them accordingly here.+    -- For example, sitePrefix is /foo, then:+    --   /foo/bar/baz.html -> bar/baz+    --   /foo/bar/bonk.html -> bar/bonk+    normalize :: FilePath -> FilePath+    normalize = (dropExtension . normalise . makeRelative (sitePath conf))++getConnection :: HaggisConfig -> IO (Maybe ConnWrapper)+getConnection conf = T.sequence $ getConnectionBuilder conf++getConnectionBuilder :: HaggisConfig -> Maybe (IO ConnWrapper)+getConnectionBuilder conf =+  fmap (\c -> liftM ConnWrapper (connectSqlite3 c)) (sqlite3File conf)++commentsEnabled :: HaggisConfig -> Bool+commentsEnabled = isJust . getConnectionBuilder++queryComments :: ConnWrapper -> IO (M.Map FilePath [Comment])+queryComments conn = do+  stmt <- prepare conn "select * from \"comments\";"+  _ <- execute stmt []+  ms <- fetchAllRowsMap' stmt+  return $ mapAccum $ map toComment ms+  where+    toComment :: M.Map String SqlValue -> (FilePath, Comment)+    toComment row =+      let c = Comment+                (get "name")+                (get "url")+                (get "email")+                (get "payload")+                (get "time")+      in ((get "slug"), c)+      where+        get :: Convertible SqlValue a => String -> a+        get col = let v = fmap fromSql (M.lookup col row)+                  in fromMaybe+                       (throw (CommentException ("couldn't find column: " ++ col)))+                       v

@@ -0,0 +1,58 @@+module Text.Haggis.Config (+  parseConfig,+  rootUri,+  readTemplates+  ) where++import Control.Applicative+import Control.Exception++import qualified Data.Map.Lazy as M+import Data.Maybe+import Data.String.Utils++import Network.URI++import Prelude hiding (catch)++import System.FilePath+import System.IO++import Text.Haggis.Parse+import Text.Haggis.Types+import Text.Parsec++parseConfig :: FilePath -> SiteTemplates -> IO HaggisConfig+parseConfig fp ts = do+  inp <- catch (readFile fp)+               (\e -> do let err = show (e :: IOException)+                         hPutStr stderr ("Problem reading: " ++ err)+                         return "")+  let kvs = dieOnParseError fp $ parse keyValueParser "" inp+  return $ buildConfig (M.fromList kvs) ts++buildConfig :: M.Map String String -> SiteTemplates -> HaggisConfig+buildConfig kvs = let get = (flip M.lookup) kvs in HaggisConfig+  (fromMaybe "/" $ get "sitePath")+  (get "defaultAuthor")+  (get "siteHost")+  (get "rssTitle")+  (get "rssDescription")+  (get "sqlite3File")++rootUri :: HaggisConfig -> Maybe URI+rootUri c = siteHost c >>= \h -> parseURI $ "http://" ++ pappend h (sitePath c)+  where+    pappend :: String -> String -> String+    pappend f s | (endswith "/" f && not (startswith "/" s)) ||+                (not (endswith "/" f) && startswith "/" s) = f ++ s+    pappend f s | not (endswith "/" f) && not (startswith "/" s) = f ++ "/" ++ s+    pappend f s = f ++ drop 1 s++readTemplates :: FilePath -> IO SiteTemplates+readTemplates fp = SiteTemplates <$> readTemplate (fp </> "root.html")+                                 <*> readTemplate (fp </> "single.html")+                                 <*> readTemplate (fp </> "multiple.html")+                                 <*> readTemplate (fp </> "tags.html")+                                 <*> readTemplate (fp </> "archives.html")+

@@ -12,7 +12,9 @@  -- * Utility functions for reading templates  readTemplate,  parseHtmlString,- parsePage+ parsePage,+ dieOnParseError,+ keyValueParser  ) where  import Control.Applicative hiding (many)@@ -27,21 +29,20 @@ import Data.Time.Calendar import Data.Time.Format -import Text.Blaze.Renderer.XmlHtml-import Text.Pandoc.Readers.Markdown-import Text.Pandoc.Writers.HTML-import Text.Pandoc.Options-import Text.Pandoc.Definition-import Text.Haggis.Types- import System.Directory import System.Posix.Files.ByteString import System.FilePath import System.FilePath.Find import System.Locale +import Text.Blaze.Renderer.XmlHtml+import Text.Pandoc.Definition+import Text.Pandoc.Options+import Text.Pandoc.Readers.Markdown+import Text.Pandoc.Writers.HTML import Text.Parsec import Text.Parsec.String+import Text.Haggis.Types import Text.XmlHtml  data ParseException = ParseException String deriving (Show, Typeable)@@ -70,8 +71,8 @@ parseHtmlString s = let parseResult = parseHTML "string" (BS.pack s)                     in either (throw . ParseException) docContent parseResult -parsePage :: FilePath -> FilePath -> IO Page-parsePage fp target = do+parsePage :: FilePath -> FilePath -> [Comment] -> IO Page+parsePage fp target comments = do   (pageBuilder, content) <- findMetadata   let Just reader = Map.lookup (takeExtension fp) fileTypes       doc = reader content@@ -83,23 +84,24 @@       if externalMd       then do         mdf <- readFile $ fp <.> "meta"-        let md = dieOnParseError $ parse keyValueParser "" mdf+        let md = dieOnParseError mdf $ parse keyValueParser "" mdf         contents <- readFile fp         return (buildPage md, contents)       else do         contents <- readFile fp-        let (md, content) = dieOnParseError $ parse inFileMetadata "" contents+        let (md, content) = dieOnParseError fp $ parse inFileMetadata "" contents         return $ (buildPage $ fromMaybe [] md, content)-    dieOnParseError :: Show e => Either e a -> a-    dieOnParseError (Left m) = throw $ ParseException (fp ++ show m)-    dieOnParseError (Right t) = t     buildPage :: [(String, String)] -> [Node] -> Page     buildPage md = let m = Map.fromList md                        title = fromMaybe "" $ Map.lookup "title" m                        author = Map.lookup "author" m                        tags = fromMaybe [] $ fmap (splitOn ", ") $ Map.lookup "tags" m                        date = Map.lookup "date" m >>= parseTime defaultTimeLocale "%F"-                   in Page title author tags date target+                   in Page title author tags date target comments++dieOnParseError :: Show e => String -> Either e a -> a+dieOnParseError prefix (Left m) = throw $ ParseException (prefix ++ show m)+dieOnParseError _ (Right t) = t  inFileMetadata :: Parser (Maybe [(String, String)], String) inFileMetadata = (,) <$> optionMaybe (string "---" *> newline *> keyValueParser <* string "---")

@@ -0,0 +1,32 @@+module Text.Haggis.RSS where++import Data.Maybe+import Data.Time.Clock++import Network.URI++import Text.Haggis.Config+import Text.Haggis.Types+import Text.Haggis.Utils+import Text.RSS++import System.FilePath++generateRSS :: HaggisConfig -> [Page] -> FilePath -> IO ()+generateRSS conf ps target = fromMaybe (return ()) $ do+  title <- rssTitle conf+  desc <- rssDescription conf+  uri <- rootUri conf+  let rss = RSS title uri desc [] $ map (buildItem uri) ps+  return $ writeFile (target </> "rss.xml") (showXML $ rssToXML rss)+  where+    buildItem :: URI -> Page -> Item+    buildItem baseURI p = concat [basic, tags, date]+      where+        basic = [ Title (pageTitle p)+                , Link (baseURI { uriPath = (uriPath baseURI) </> pagePath p })+                , Description (show $ renderHtml $ pageContent p)+                ]+        tags = map (Category Nothing) $ pageTags p+        date = maybeToList $ fmap (\d -> PubDate (UTCTime d midnight)) (pageDate p)+        midnight = secondsToDiffTime 0

@@ -1,4 +1,6 @@ module Text.Haggis.Types (+  -- * A haggis configuration.+  HaggisConfig(..),   -- * Container for the required site templates   SiteTemplates(..),   -- * Representation of a single haggis page@@ -10,10 +12,14 @@   MultiPageType(..),   -- ** conversions for 'MultiPageType's   mpTypeToPath,-  mpTypeToTitle+  mpTypeToTitle,+  -- * A comment on a haggis post+  Comment(..)   ) where  import Data.Time.Calendar+import Data.Time.Clock+import Data.Time.LocalTime () -- for Show UTCTime import Data.Maybe  import System.FilePath@@ -35,6 +41,7 @@   pageDate :: Maybe Day,   -- The 'pagePath' is relative to the source dir.   pagePath :: FilePath,+  pageComments :: [Comment],   -- This is the content as rendered by pandoc (i.e. it has not been bound to   -- the single.html template)   pageContent :: [Node]@@ -63,4 +70,33 @@ data MultiPage = MultiPage {   singlePages :: [Page],   multiPageType :: MultiPageType+} deriving (Show)++data HaggisConfig = HaggisConfig {+  -- | Path to where the files are hosted, e.g: /foo, /, /foo/bar/, defaults+  -- to /+  sitePath :: String,++  -- | Default author, so you don't have to put an author in every post's+  -- metadata.+  defaultAuthor :: Maybe String,++  -- | Hostname where the blog is hosted, used for generating RSS feed links.+  -- E.g. blog.example.com+  siteHost :: Maybe String,+  rssTitle :: Maybe String,+  rssDescription :: Maybe String,++  -- | Sqlite3 file name, for comments.+  sqlite3File :: Maybe FilePath,++  siteTemplates :: SiteTemplates+} deriving (Show)++data Comment = Comment {+  commenterName :: String,+  commenterUrl :: Maybe String,+  commenterEmail :: Maybe String,+  commentPayload :: String,+  commentTime :: UTCTime } deriving (Show)

@@ -0,0 +1,21 @@+module Text.Haggis.Utils where++import Blaze.ByteString.Builder++import qualified Data.ByteString.Lazy as BS+import qualified Data.Map.Lazy as M++import Text.Blaze.Renderer.XmlHtml+import Text.Pandoc.Definition+import Text.Pandoc.Options+import Text.Pandoc.Writers.HTML+import Text.XmlHtml++renderHtml :: [Node] -> BS.ByteString+renderHtml = toLazyByteString . renderHtmlFragment UTF8++mapAccum :: Ord a => [(a, b)] -> M.Map a [b]+mapAccum = foldr (\(k,v) -> M.insertWith (++) k [v]) M.empty++pandocToHtml :: Pandoc -> [Node]+pandocToHtml = renderHtmlNodes . writeHtml def

@@ -12,11 +12,11 @@ options = BloghOpts     <$> strOption         ( long "input"-       <> metavar "INPUT"+       <> metavar "DIR"        <> help "Input contents (directory) for your web site." )     <*> strOption         ( long "output"-       <> metavar "OUTPUT"+       <> metavar "DIR"        <> help "Output directory for site results." )  run :: BloghOpts -> IO ()