packages feed

haggis (empty) → 0.1.0.0

raw patch · 8 files changed

+462/−0 lines, 8 filesdep +basedep +blaze-builderdep +bytestringsetup-changed

Dependencies added: base, blaze-builder, bytestring, containers, directory, filemanip, filepath, haggis, hquery, old-locale, optparse-applicative, pandoc, pandoc-types, parsec, split, text, time, unix, xmlhtml

Files

+ LICENSE view
@@ -0,0 +1,21 @@+// MIT++Copyright (c) 2013 Tycho Andersen++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haggis.cabal view
@@ -0,0 +1,39 @@+name:                haggis+version:             0.1.0.0+synopsis:            A static site generator with blogging/comments support+homepage:            http://github.com/tych0/haggis+license:             MIT+license-file:        LICENSE+author:              Tycho Andersen+maintainer:          Tycho Andersen <tycho@tycho.ws>+category:            Web+build-type:          Simple+cabal-version:       >=1.8+bug-reports:         https://github.com/tych0/haggis/issues+description: Haggis is a static site generator with support for blogging.+             Haggis has very few restrictions on how you manage your content,+             and supports any markup format that pandoc does.++source-repository head+  type:              git+  location:          git://github.com/tych0/haggis.git++library+  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,+                 time >= 1.4, old-locale, parsec >= 3.1, split >= 0.2,+                 text >= 0.11+  hs-source-dirs: src+  exposed-modules: Text.Haggis, Text.Haggis.Parse, Text.Haggis.Types,+                   Text.Haggis.Binders+  ghc-options: -Wall++executable haggis+  main-is: haggis.hs+  hs-source-dirs: tools+  build-depends: base ==4.*, filemanip >= 0.3, filepath >= 1.3,+                 optparse-applicative >= 0.5, directory >= 1.1,+                 haggis >= 0.1.0.0+  ghc-options: -Wall
+ src/Text/Haggis.hs view
@@ -0,0 +1,140 @@+module Text.Haggis (+  -- * Site generation entry point+  buildSite+  ) where++import Blaze.ByteString.Builder++import Control.Applicative++import qualified Data.ByteString.Lazy as BS+import Data.Either+import Data.Function+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Time.Calendar++import System.Posix.Files.ByteString+import System.FilePath+import System.FilePath.Find+import System.Directory++import Text.XmlHtml++import Text.Haggis.Binders+import Text.Haggis.Parse+import Text.Haggis.Types+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+  let (raws, pages) = partitionEithers actions+  readPages <- sequence pages+  let multiPages = generateAggregates readPages+      specialPages = generateSpecial templates multiPages+      allPages = concat [readPages, specialPages]+  writeSite allPages multiPages templates tgt+  sequence_ raws++writeSite :: [Page] -> [MultiPage] -> SiteTemplates -> FilePath -> IO ()+writeSite ps mps templates out = do+  sequence_ $ map writePage ps+  sequence_ $ map writeMultiPage mps+  where+    wrapper = bindSpecial mps $ root templates+    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+    writePage :: Page -> IO ()+    writePage p =+      let content = bindPage p $ single templates+      in writeThing (pagePath p) (pageTitle p) content+    writeMultiPage :: MultiPage -> IO ()+    writeMultiPage mp =+      let xform = hq ".page *" $ map bindPage $ singlePages mp+          content = xform $ multiple templates+          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)+      archives = plainPage "Archives" "./archives/index.html" archivesContent+      tagsContent = bind (tagsTemplate templates)+      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++generateAggregates :: [Page] -> [MultiPage]+generateAggregates ps =+  let tagPages = buildMultiPages Tag tags+      indexPages = buildMultiPages DirIndex indexes+      yearPages = buildMultiPages id yearArchives+      monthPages = buildMultiPages id monthArchives+      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+    monthAndYearOf d = let (y, m, _) = toGregorian d in (y, Just m)+    yearOf d = let (y, _) = monthAndYearOf d in (y, Nothing)+    buildArchive f =+      mapAccum $ catMaybes $ map (\p -> fmap (\d -> (uncurry Archive $ f d, p)) $ pageDate p) ps+    yearArchives = buildArchive yearOf+    monthArchives = buildArchive monthAndYearOf+    buildMultiPages :: (a -> MultiPageType) -> M.Map a [Page] -> [MultiPage]+    buildMultiPages typeBuilder pm =+      map (\(name, pages) -> MultiPage pages $ typeBuilder name) $ M.toList pm+    recent = let hasDate = filter (isJust . pageDate) ps+             in take 10 $ reverse $ sortBy (compare `on` pageDate) hasDate++type Accum = [Either (IO ()) (IO Page)]+collectSiteElements ::+  FilePath ->+  FilePath ->+  IO Accum+collectSiteElements src tgt = foldWithHandler+  ignoreExceptions+  always+  accumulate+  []+  src+  where+    accumulate :: Accum -> FileInfo -> Accum+    accumulate acc info = makeAction info : acc+    ignoreExceptions _ a _ = return a+    mkRelative :: FilePath -> FilePath+    mkRelative = makeRelative src+    makeAction :: FileInfo -> Either (IO ()) (IO Page)+    makeAction info | supported info = Right $ do+      let path = infoPath info+          target = replaceExtension (mkRelative path) ".html"+      parsePage path target+    makeAction info | isRegularFile $ infoStatus info = Left $ do+      let path = infoPath info+      let target = tgt </> mkRelative path+      ensureDirExists target+      copyFile path target+    makeAction _ = Left (return ()) -- TODO: follow symlinks?
+ src/Text/Haggis/Binders.hs view
@@ -0,0 +1,50 @@+{- | Contains binding utility functions. -}+module Text.Haggis.Binders (+  -- * Create a transformer which will bind the 'Page' to a template.+  bindPage,+  -- * Bind the specified tag to an anchor.+  bindTag,+  -- * Bind the archives and tags.+  bindSpecial+  ) where++import Data.Either++import System.FilePath++import Text.Haggis.Types+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)++bindTag :: String -> [Node] -> [Node]+bindTag t = hq ".tag [href]" ("/" </> (mpTypeToPath $ Tag t)) .+            hq ".tag *" (t ++ ", ")++bindSpecial :: [MultiPage] -> [Node] -> [Node]+bindSpecial 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 *" (show y ++ " - " ++ show m)+                         bind (MultiPage xs typ@(Tag t)) = Right $+                           hq ".tag [href]" ("/" </> mpTypeToPath typ) .+                           hq ".tag *" (t ++ " (" ++ show (length xs) ++ "), ")+                         bind _ = Left $ hq "*" nothing+                     in partitionEithers $ map bind mps+
+ src/Text/Haggis/Parse.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoAndIfThenElse #-} -- TODO: get rid of this?+module Text.Haggis.Parse (+ -- * Exception thrown when some template or user input document fails to+ --   parse+ ParseException(..),++ -- * Is this a pandoc supported file?+ supported,+ -- * Parse a date in YYYY-MM-DD format.+ parseDate,+ -- * Utility functions for reading templates+ readTemplate,+ parseHtmlString,+ parsePage+ ) where++import Control.Applicative hiding (many)+import Control.Exception++import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.List.Split+import qualified Data.Map as Map+import Data.Maybe+import Data.Typeable+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.Parsec+import Text.Parsec.String+import Text.XmlHtml++data ParseException = ParseException String deriving (Show, Typeable)+instance Exception ParseException++fileTypes :: Map.Map String (String -> Pandoc)+fileTypes = Map.fromList [ (".md", readMarkdown def)+                         ]++isSupportedExt :: String -> Bool+isSupportedExt s = Map.member (map toLower s) fileTypes++supported :: FileInfo -> Bool+supported info = (isRegularFile . infoStatus) info &&+                 (isSupportedExt . takeExtension . infoPath) info++parseDate :: String -> Maybe Day+parseDate = parseTime defaultTimeLocale "%F"++readTemplate :: FilePath -> IO [Node]+readTemplate fp = do+  inp <- readFile fp+  return $ parseHtmlString inp++parseHtmlString :: String -> [Node]+parseHtmlString s = let parseResult = parseHTML "string" (BS.pack s)+                    in either (throw . ParseException) docContent parseResult++parsePage :: FilePath -> FilePath -> IO Page+parsePage fp target = do+  (pageBuilder, content) <- findMetadata+  let Just reader = Map.lookup (takeExtension fp) fileTypes+      doc = reader content+  return $ pageBuilder $ renderHtmlNodes $ writeHtml def doc+  where+    findMetadata :: IO ([Node] -> Page, String)+    findMetadata = do+      externalMd <- doesFileExist $ fp <.> "meta"+      if externalMd+      then do+        mdf <- readFile $ fp <.> "meta"+        let md = dieOnParseError $ parse keyValueParser "" mdf+        contents <- readFile fp+        return (buildPage md, contents)+      else do+        contents <- readFile fp+        let (md, content) = dieOnParseError $ 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++inFileMetadata :: Parser (Maybe [(String, String)], String)+inFileMetadata = (,) <$> optionMaybe (string "---" *> newline *> keyValueParser <* string "---")+                     <*> many anyChar++keyValueParser :: Parser [(String, String)]+keyValueParser = many keyValuePair+  where+    keyValuePair :: Parser (String, String)+    keyValuePair = (,) <$> (many alphaNum <* string ":" <* spaces)+                       <*> many (satisfy ((/=) '\n') <?> "printable") <* newline
+ src/Text/Haggis/Types.hs view
@@ -0,0 +1,66 @@+module Text.Haggis.Types (+  -- * Container for the required site templates+  SiteTemplates(..),+  -- * Representation of a single haggis page+  Page(..),+  -- * Representation of multiple pages (e.g. an index.html for a directory,+  --   or a list of posts with a specific tag)+  MultiPage(..),+  -- * The type of the pages+  MultiPageType(..),+  -- ** conversions for 'MultiPageType's+  mpTypeToPath,+  mpTypeToTitle+  ) where++import Data.Time.Calendar+import Data.Maybe++import System.FilePath++import Text.XmlHtml++data SiteTemplates = SiteTemplates {+  root :: [Node],+  single :: [Node],+  multiple :: [Node],+  tagsTemplate :: [Node],+  archivesTemplate :: [Node]+} deriving (Show)++data Page = Page {+  pageTitle :: String,+  pageAuthor :: Maybe String,+  pageTags :: [String],+  pageDate :: Maybe Day,+  -- The 'pagePath' is relative to the source dir.+  pagePath :: FilePath,+  -- This is the content as rendered by pandoc (i.e. it has not been bound to+  -- the single.html template)+  pageContent :: [Node]+} deriving (Show)++data MultiPageType =+  Tag String |+  DirIndex FilePath |+  Archive Integer (Maybe Int)+  deriving (Eq, Ord, Show)++mpTypeToPath :: MultiPageType -> FilePath+mpTypeToPath (Tag t) = "tags" </> t <.> "html"+mpTypeToPath (DirIndex d) = d </> "index.html"+mpTypeToPath (Archive y m) =+  let month = fromMaybe "index" $ fmap show m+  in "archives" </> show y </> month <.> "html"++mpTypeToTitle :: MultiPageType -> String+mpTypeToTitle (Tag t) = "Tagged: " ++ t+mpTypeToTitle (DirIndex d) = "Filed under: " ++ d+mpTypeToTitle (Archive y m) =+  let month = fromMaybe "" $ fmap ((" - " ++) . show) m+  in "Posts from: " ++ (show y) ++ month++data MultiPage = MultiPage {+  singlePages :: [Page],+  multiPageType :: MultiPageType+} deriving (Show)
+ tools/haggis.hs view
@@ -0,0 +1,31 @@+module Main where++import Options.Applicative++import Text.Haggis++data BloghOpts = BloghOpts { input :: String+                           , output :: String+                           }++options :: Parser BloghOpts+options = BloghOpts+    <$> strOption+        ( long "input"+       <> metavar "INPUT"+       <> help "Input contents (directory) for your web site." )+    <*> strOption+        ( long "output"+       <> metavar "OUTPUT"+       <> help "Output directory for site results." )++run :: BloghOpts -> IO ()+run opts = buildSite (input opts) (output opts)++main :: IO ()+main = execParser opts >>= run+  where+    opts = info (helper <*> options)+      ( fullDesc+     <> progDesc "Generate a haggis blog."+     <> header "haggis - a static site generator" )