diff --git a/haggis.cabal b/haggis.cabal --- a/haggis.cabal +++ b/haggis.cabal @@ -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 diff --git a/src/Text/Haggis.hs b/src/Text/Haggis.hs --- a/src/Text/Haggis.hs +++ b/src/Text/Haggis.hs @@ -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 diff --git a/src/Text/Haggis/Binders.hs b/src/Text/Haggis/Binders.hs --- a/src/Text/Haggis/Binders.hs +++ b/src/Text/Haggis/Binders.hs @@ -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 diff --git a/src/Text/Haggis/Comments.hs b/src/Text/Haggis/Comments.hs new file mode 100644 --- /dev/null +++ b/src/Text/Haggis/Comments.hs @@ -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 diff --git a/src/Text/Haggis/Config.hs b/src/Text/Haggis/Config.hs new file mode 100644 --- /dev/null +++ b/src/Text/Haggis/Config.hs @@ -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") + diff --git a/src/Text/Haggis/Parse.hs b/src/Text/Haggis/Parse.hs --- a/src/Text/Haggis/Parse.hs +++ b/src/Text/Haggis/Parse.hs @@ -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 "---") diff --git a/src/Text/Haggis/RSS.hs b/src/Text/Haggis/RSS.hs new file mode 100644 --- /dev/null +++ b/src/Text/Haggis/RSS.hs @@ -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 diff --git a/src/Text/Haggis/Types.hs b/src/Text/Haggis/Types.hs --- a/src/Text/Haggis/Types.hs +++ b/src/Text/Haggis/Types.hs @@ -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) diff --git a/src/Text/Haggis/Utils.hs b/src/Text/Haggis/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/Haggis/Utils.hs @@ -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 diff --git a/tools/haggis.hs b/tools/haggis.hs --- a/tools/haggis.hs +++ b/tools/haggis.hs @@ -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 ()