diff --git a/hakyll.cabal b/hakyll.cabal --- a/hakyll.cabal +++ b/hakyll.cabal @@ -1,5 +1,5 @@ Name: hakyll -Version: 2.2.2 +Version: 2.3 Synopsis: A simple static site generator library. Description: A simple static site generator library, mainly aimed at @@ -38,8 +38,9 @@ mtl == 1.*, old-locale == 1.*, old-time == 1.*, - time == 1.*, - binary >= 0.5 + time >= 1.2, + binary >= 0.5, + hamlet >= 0.4.2 exposed-modules: Network.Hakyll.SimpleServer Text.Hakyll Text.Hakyll.Context @@ -54,9 +55,12 @@ Text.Hakyll.Util Text.Hakyll.Tags Text.Hakyll.Feed + Text.Hakyll.Configurations.Static other-modules: Paths_hakyll Text.Hakyll.Internal.Cache Text.Hakyll.Internal.CompressCss Text.Hakyll.Internal.FileType Text.Hakyll.Internal.Page Text.Hakyll.Internal.Template + Text.Hakyll.Internal.Template.Template + Text.Hakyll.Internal.Template.Hamlet diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs --- a/src/Text/Hakyll.hs +++ b/src/Text/Hakyll.hs @@ -11,18 +11,23 @@ ( defaultHakyllConfiguration , hakyll , hakyllWithConfiguration + , runDefaultHakyll ) where +import Control.Concurrent (forkIO, threadDelay) import Control.Monad.Reader (runReaderT, liftIO, ask) import Control.Monad (when) import Data.Monoid (mempty) import System.Environment (getArgs, getProgName) import System.Directory (doesDirectoryExist, removeDirectoryRecursive) +import System.Time (getClockTime) import Text.Pandoc +import Text.Hamlet (defaultHamletSettings) import Network.Hakyll.SimpleServer (simpleServer) import Text.Hakyll.HakyllMonad +import Text.Hakyll.File -- | The default reader options for pandoc parsing. -- @@ -52,8 +57,10 @@ , siteDirectory = "_site" , cacheDirectory = "_cache" , enableIndexUrl = False + , previewMode = BuildOnRequest , pandocParserState = defaultPandocParserState , pandocWriterOptions = defaultPandocWriterOptions + , hamletSettings = defaultHamletSettings } -- | Main function to run Hakyll with the default configuration. The @@ -74,14 +81,36 @@ args <- getArgs let f = case args of ["build"] -> buildFunction ["clean"] -> clean - ["preview", p] -> server (read p) buildFunction - ["preview"] -> server 8000 buildFunction + ["preview", p] -> preview (read p) + ["preview"] -> preview defaultPort ["rebuild"] -> clean >> buildFunction ["server", p] -> server (read p) (return ()) - ["server"] -> server 8000 (return ()) + ["server"] -> server defaultPort (return ()) _ -> help runReaderT f configuration + where + preview port = case previewMode configuration of + BuildOnRequest -> server port buildFunction + BuildOnInterval -> do + let pIO = runReaderT (previewThread buildFunction) configuration + _ <- liftIO $ forkIO pIO + server port (return ()) + defaultPort = 8000 + +-- | A preview thread that periodically recompiles the site. +-- +previewThread :: Hakyll () -- ^ Build function + -> Hakyll () -- ^ Result +previewThread buildFunction = run =<< liftIO getClockTime + where + delay = 1000000 + run time = do liftIO $ threadDelay delay + contents <- getRecursiveContents "." + valid <- isMoreRecent time contents + when valid buildFunction + run =<< liftIO getClockTime + -- | Clean up directories. -- clean :: Hakyll () @@ -118,3 +147,10 @@ root <- askHakyll siteDirectory let preRespondIO = runReaderT preRespond configuration liftIO $ simpleServer (fromIntegral port) root preRespondIO + +-- | Run a Hakyll action with default settings. This is mostly aimed at testing +-- code. +-- +runDefaultHakyll :: Hakyll a -> IO a +runDefaultHakyll f = + runReaderT f $ defaultHakyllConfiguration "http://example.com" diff --git a/src/Text/Hakyll/Configurations/Static.hs b/src/Text/Hakyll/Configurations/Static.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Configurations/Static.hs @@ -0,0 +1,59 @@ +-- | Module for a simple static configuration of a website. +-- +-- The configuration works like this: +-- +-- * The @templates/@ directory should contain one template. +-- +-- * Renderable files in the directory tree are rendered using this template. +-- +-- * The @static/@ directory is copied entirely (if it exists). +-- +-- * All files in the @css/@ directory are compressed. +-- +module Text.Hakyll.Configurations.Static + ( staticConfiguration + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (filterM, forM_) + +import Text.Hakyll.File ( getRecursiveContents, inDirectory, inHakyllDirectory + , directory ) +import Text.Hakyll.Internal.FileType (isRenderableFile) +import Text.Hakyll.HakyllMonad (Hakyll, logHakyll) +import Text.Hakyll.Render (renderChain, css, static) +import Text.Hakyll.CreateContext (createPage) + +-- | A simple configuration for an entirely static website. +-- +staticConfiguration :: Hakyll () +staticConfiguration = do + -- Find all files not in _site or _cache. + files <- filterM isRenderableFile' =<< getRecursiveContents "." + + -- Find a main template to use + mainTemplate <- take 1 <$> getRecursiveContents templateDir + logHakyll $ case mainTemplate of [] -> "Using no template" + (x : _) -> "Using template " ++ x + + -- Render all files using this template + forM_ files $ renderChain mainTemplate . createPage + + -- Render a static directory + directory static staticDir + + -- Render a css directory + directory css cssDir + where + -- A file should have a renderable extension and not be in a hakyll + -- directory, and not in a special directory. + isRenderableFile' file = do + inHakyllDirectory' <- inHakyllDirectory file + return $ isRenderableFile file + && not (any (inDirectory file) [templateDir, cssDir, staticDir]) + && not inHakyllDirectory' + + -- Directories + templateDir = "templates" + cssDir = "css" + staticDir = "static" diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs --- a/src/Text/Hakyll/File.hs +++ b/src/Text/Hakyll/File.hs @@ -5,6 +5,8 @@ , toCache , toUrl , toRoot + , inDirectory + , inHakyllDirectory , removeSpaces , makeDirectories , getRecursiveContents @@ -16,6 +18,7 @@ ) where import System.Directory +import Control.Applicative ((<$>)) import System.FilePath import System.Time (ClockTime) import Control.Monad @@ -85,6 +88,32 @@ emptyException [] = "." emptyException x = x +-- | Check if a file is in a given directory. +-- +inDirectory :: FilePath -- ^ File path + -> FilePath -- ^ Directory + -> Bool -- ^ Result +inDirectory path dir = case splitDirectories path of + [] -> False + (x : _) -> x == dir + +-- | Check if a file is in a Hakyll directory. With a Hakyll directory, we mean +-- a directory that should be "ignored" such as the @_site@ or @_cache@ +-- directory. +-- +-- Example: +-- +-- > inHakyllDirectory "_cache/pages/index.html" +-- +-- Result: +-- +-- > True +-- +inHakyllDirectory :: FilePath -> Hakyll Bool +inHakyllDirectory path = + or <$> mapM (liftM (inDirectory path) . askHakyll) + [siteDirectory, cacheDirectory] + -- | Swaps spaces for '-'. removeSpaces :: FilePath -> FilePath removeSpaces = map swap @@ -101,17 +130,21 @@ -- | Get all contents of a directory. Note that files starting with a dot (.) -- will be ignored. +-- getRecursiveContents :: FilePath -> Hakyll [FilePath] getRecursiveContents topdir = do - names <- liftIO $ getDirectoryContents topdir - let properNames = filter isProper names - paths <- forM properNames $ \name -> do - let path = topdir name - isDirectory <- liftIO $ doesDirectoryExist path - if isDirectory - then getRecursiveContents path - else return [path] - return (concat paths) + topdirExists <- liftIO $ doesDirectoryExist topdir + if topdirExists + then do names <- liftIO $ getDirectoryContents topdir + let properNames = filter isProper names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- liftIO $ doesDirectoryExist path + if isDirectory + then getRecursiveContents path + else return [normalise path] + return (concat paths) + else return [] where isProper = not . (== '.') . head diff --git a/src/Text/Hakyll/HakyllAction.hs b/src/Text/Hakyll/HakyllAction.hs --- a/src/Text/Hakyll/HakyllAction.hs +++ b/src/Text/Hakyll/HakyllAction.hs @@ -12,9 +12,7 @@ import Control.Arrow import Control.Category import Control.Monad ((<=<), unless) -import Control.Monad.Reader (liftIO) import Prelude hiding ((.), id) -import System.IO (hPutStrLn, stderr) import Text.Hakyll.File (toDestination, isFileMoreRecent) import Text.Hakyll.HakyllMonad @@ -65,7 +63,7 @@ Right _ -> error "No url when checking dependencies." destination <- toDestination url valid <- isFileMoreRecent destination $ actionDependencies action - unless valid $ do liftIO $ hPutStrLn stderr $ "Rendering " ++ destination + unless valid $ do logHakyll $ "Rendering " ++ destination runHakyllAction action -- | Chain a number of @HakyllAction@ computations. diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs --- a/src/Text/Hakyll/HakyllMonad.hs +++ b/src/Text/Hakyll/HakyllMonad.hs @@ -1,23 +1,36 @@ -- | Module describing the Hakyll monad stack. module Text.Hakyll.HakyllMonad ( HakyllConfiguration (..) + , PreviewMode (..) , Hakyll , askHakyll , getAdditionalContext + , logHakyll ) where +import Control.Monad.Trans (liftIO) import Control.Monad.Reader (ReaderT, ask) import Control.Monad (liftM) import qualified Data.Map as M +import System.IO (hPutStrLn, stderr) import Text.Pandoc (ParserState, WriterOptions) +import Text.Hamlet (HamletSettings) import Text.Hakyll.Context (Context (..)) -- | Our custom monad stack. +-- type Hakyll = ReaderT HakyllConfiguration IO +-- | Preview mode. +-- +data PreviewMode = BuildOnRequest + | BuildOnInterval + deriving (Show, Eq, Ord) + -- | Hakyll global configuration type. +-- data HakyllConfiguration = HakyllConfiguration { -- | Absolute URL of the site. absoluteUrl :: String @@ -30,10 +43,14 @@ cacheDirectory :: FilePath , -- | Enable index links. enableIndexUrl :: Bool + , -- | The preview mode used + previewMode :: PreviewMode , -- | Pandoc parsing options pandocParserState :: ParserState , -- | Pandoc writer options pandocWriterOptions :: WriterOptions + , -- | Hamlet settings (if you use hamlet for templates) + hamletSettings :: HamletSettings } -- | Simplified @ask@ function for the Hakyll monad stack. @@ -48,7 +65,14 @@ askHakyll :: (HakyllConfiguration -> a) -> Hakyll a askHakyll = flip liftM ask +-- | Obtain the globally available, additional context. +-- getAdditionalContext :: HakyllConfiguration -> Context getAdditionalContext configuration = let (Context c) = additionalContext configuration in Context $ M.insert "absolute" (absoluteUrl configuration) c + +-- | Write some log information. +-- +logHakyll :: String -> Hakyll () +logHakyll = liftIO . hPutStrLn stderr diff --git a/src/Text/Hakyll/Internal/Template.hs b/src/Text/Hakyll/Internal/Template.hs --- a/src/Text/Hakyll/Internal/Template.hs +++ b/src/Text/Hakyll/Internal/Template.hs @@ -10,8 +10,6 @@ import Control.Applicative ((<$>)) import Data.List (isPrefixOf) import Data.Char (isAlphaNum) -import Data.Binary -import Control.Monad (liftM, liftM2) import Data.Maybe (fromMaybe) import System.FilePath (()) import qualified Data.Map as M @@ -20,25 +18,26 @@ import Text.Hakyll.HakyllMonad (Hakyll) import Text.Hakyll.Internal.Cache import Text.Hakyll.Internal.Page - --- | Datatype used for template substitutions. -data Template = Chunk String Template - | Identifier String Template - | EscapeCharacter Template - | End - deriving (Show, Read, Eq) +import Text.Hakyll.Internal.Template.Template +import Text.Hakyll.Internal.Template.Hamlet -- | Construct a @Template@ from a string. +-- fromString :: String -> Template -fromString [] = End -fromString string - | "$$" `isPrefixOf` string = EscapeCharacter (fromString $ tail tail') - | "$" `isPrefixOf` string = let (key, rest) = span isAlphaNum tail' - in Identifier key (fromString rest) - | otherwise = let (chunk, rest) = break (== '$') string - in Chunk chunk (fromString rest) +fromString = Template . fromString' where - tail' = tail string + fromString' [] = [] + fromString' string + | "$$" `isPrefixOf` string = + EscapeCharacter : (fromString' $ tail tail') + | "$" `isPrefixOf` string = + let (key, rest) = span isAlphaNum tail' + in Identifier key : fromString' rest + | otherwise = + let (chunk, rest) = break (== '$') string + in Chunk chunk : fromString' rest + where + tail' = tail string -- | Read a @Template@ from a file. This function might fetch the @Template@ -- from the cache, if available. @@ -48,28 +47,31 @@ if isCacheMoreRecent' then getFromCache fileName else do - page <- unContext <$> readPage path - let body = fromMaybe (error $ "No body in template " ++ fileName) - (M.lookup "body" page) - template = fromString body + template <- if isHamletRTFile path + then readHamletTemplate + else readDefaultTemplate storeInCache template fileName return template where fileName = "templates" path + readDefaultTemplate = do + page <- unContext <$> readPage path + let body = fromMaybe (error $ "No body in template " ++ fileName) + (M.lookup "body" page) + return $ fromString body + readHamletTemplate = fromHamletRT <$> readHamletRT path + -- | Substitutes @$identifiers@ in the given @Template@ by values from the given -- "Context". When a key is not found, it is left as it is. You can specify -- the characters used to replace escaped dollars (@$$@) here. substitute :: String -> Template -> Context -> String -substitute escaper (Chunk chunk template) context = - chunk ++ substitute escaper template context -substitute escaper (Identifier key template) context = - replacement ++ substitute escaper template context +substitute escaper template context = substitute' =<< unTemplate template where - replacement = fromMaybe ('$' : key) $ M.lookup key $ unContext context -substitute escaper (EscapeCharacter template) context = - escaper ++ substitute escaper template context -substitute _ End _ = [] + substitute' (Chunk chunk) = chunk + substitute' (Identifier key) = + fromMaybe ('$' : key) $ M.lookup key $ unContext context + substitute' (EscapeCharacter) = escaper -- | @substitute@ for use during a chain. This will leave escaped characters as -- they are. @@ -80,16 +82,3 @@ -- escaped characters. finalSubstitute :: Template -> Context -> String finalSubstitute = substitute "$" - -instance Binary Template where - put (Chunk string template) = put (0 :: Word8) >> put string >> put template - put (Identifier key template) = put (1 :: Word8) >> put key >> put template - put (EscapeCharacter template) = put (2 :: Word8) >> put template - put (End) = put (3 :: Word8) - - get = do tag <- getWord8 - case tag of 0 -> liftM2 Chunk get get - 1 -> liftM2 Identifier get get - 2 -> liftM EscapeCharacter get - 3 -> return End - _ -> error "Error reading template" diff --git a/src/Text/Hakyll/Internal/Template/Hamlet.hs b/src/Text/Hakyll/Internal/Template/Hamlet.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Internal/Template/Hamlet.hs @@ -0,0 +1,56 @@ +-- | Support for Hamlet templates in Hakyll. +-- +module Text.Hakyll.Internal.Template.Hamlet + ( isHamletRTFile + , readHamletRT + , fromHamletRT + ) where + +import Control.Exception (try) +import Control.Monad.Trans (liftIO) +import System.FilePath (takeExtension) + +import Text.Hamlet.RT + +import Text.Hakyll.Internal.Template.Template +import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, hamletSettings, logHakyll) + +-- | Determine if a file is a hamlet template by extension. +-- +isHamletRTFile :: FilePath -> Bool +isHamletRTFile fileName = takeExtension fileName `elem` [".hamlet", ".hml"] + +-- | Read a 'HamletRT' by file name. +-- +readHamletRT :: FilePath -- ^ Filename of the template + -> Hakyll HamletRT -- ^ Resulting hamlet template +readHamletRT fileName = do + settings <- askHakyll hamletSettings + string <- liftIO $ readFile fileName + result <- liftIO $ try $ parseHamletRT settings string + case result of + Left (HamletParseException s) -> error' s + Left (HamletUnsupportedDocException d) -> error' $ show d + Left (HamletRenderException s) -> error' s + Right x -> return x + where + error' s = do + logHakyll $ "Parse of hamlet file " ++ fileName ++ " failed." + logHakyll s + error "Parse failed." + +-- | Convert a 'HamletRT' to a 'Template' +-- +fromHamletRT :: HamletRT -- ^ Hamlet runtime template + -> Template -- ^ Hakyll template +fromHamletRT (HamletRT sd) = Template $ map fromSimpleDoc sd + where + fromSimpleDoc :: SimpleDoc -> TemplateElement + fromSimpleDoc (SDRaw chunk) = Chunk chunk + fromSimpleDoc (SDVar [var]) = Identifier var + fromSimpleDoc (SDVar _) = + error "Hakyll does not support '.' in identifier names when using \ + \hamlet templates." + fromSimpleDoc _ = + error "Only simple $key$ identifiers are allowed when using hamlet \ + \templates." diff --git a/src/Text/Hakyll/Internal/Template/Template.hs b/src/Text/Hakyll/Internal/Template/Template.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Internal/Template/Template.hs @@ -0,0 +1,34 @@ +-- | Module containing the template data structure. +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Text.Hakyll.Internal.Template.Template + ( Template (..) + , TemplateElement (..) + ) where + +import Control.Applicative ((<$>)) + +import Data.Binary (Binary, get, getWord8, put, putWord8) + +-- | Datatype used for template substitutions. +-- +newtype Template = Template { unTemplate :: [TemplateElement] } + deriving (Show, Eq, Binary) + +-- | Elements of a template. +-- +data TemplateElement = Chunk String + | Identifier String + | EscapeCharacter + deriving (Show, Eq) + +instance Binary TemplateElement where + put (Chunk string) = putWord8 0 >> put string + put (Identifier key) = putWord8 1 >> put key + put (EscapeCharacter) = putWord8 2 + + get = getWord8 >>= \tag -> + case tag of 0 -> Chunk <$> get + 1 -> Identifier <$> get + 2 -> return EscapeCharacter + _ -> error "Error reading cached template" diff --git a/src/Text/Hakyll/Paginate.hs b/src/Text/Hakyll/Paginate.hs --- a/src/Text/Hakyll/Paginate.hs +++ b/src/Text/Hakyll/Paginate.hs @@ -1,4 +1,5 @@ -- | Module aimed to paginate web pages. +-- module Text.Hakyll.Paginate ( PaginateConfiguration (..) , defaultPaginateConfiguration @@ -13,6 +14,7 @@ import Text.Hakyll.Util (link) -- | A configuration for a pagination. +-- data PaginateConfiguration = PaginateConfiguration { -- | Label for the link to the previous page. previousLabel :: String @@ -25,6 +27,7 @@ } -- | A simple default configuration for pagination. +-- defaultPaginateConfiguration :: PaginateConfiguration defaultPaginateConfiguration = PaginateConfiguration { previousLabel = "Previous" @@ -54,6 +57,7 @@ -- When @$previous@ or @$next@ are not available, they will be just a label -- without a link. The same goes for when we are on the first or last page for -- @$first@ and @$last@. +-- paginate :: PaginateConfiguration -> [HakyllAction () Context] -> [HakyllAction () Context] @@ -61,7 +65,8 @@ where -- Create a link with a given label, taken from the configuration. linkWithLabel f r = Right $ case actionUrl r of - Left l -> createSimpleHakyllAction $ link (f configuration) <$> l + Left l -> createSimpleHakyllAction $ + link (f configuration) . ("$root/" ++) <$> l Right _ -> error "No link found for pagination." -- The main function that creates combined renderables by recursing over