diff --git a/hakyll.cabal b/hakyll.cabal
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -1,10 +1,10 @@
Name: hakyll
-Version: 0.3.2
+Version: 0.4
Synopsis: A simple static site generator library.
Description:
- A simple static site generator library , mainly aimed at
- creating blogs.
+ A simple static site generator library, mainly aimed at
+ creating blogs and brochure sites.
Author: Jasper Van der Jeugt
Maintainer: jaspervdj@gmail.com
Homepage: http://jaspervdj.be/hakyll
@@ -24,10 +24,12 @@
directory >= 1,
containers >= 0.1,
bytestring >= 0.9 && <= 0.9.1.4,
- pandoc >= 1.3,
+ pandoc >= 1,
regex-compat >= 0.92,
network >= 2,
- mtl >= 1.1
+ mtl >= 1.1,
+ old-locale >= 1,
+ time >= 1
exposed-modules: Text.Hakyll
Text.Hakyll.Render
Text.Hakyll.Renderable
@@ -37,4 +39,5 @@
Text.Hakyll.Page
Text.Hakyll.Util
Text.Hakyll.Tags
+ Text.Hakyll.Context
Network.Hakyll.SimpleServer
diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs
--- a/src/Network/Hakyll/SimpleServer.hs
+++ b/src/Network/Hakyll/SimpleServer.hs
@@ -4,22 +4,29 @@
( simpleServer
) where
+import Prelude hiding (log)
import Network
import Control.Monad (forever, mapM_)
import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
-import System.IO (Handle, hClose, hGetLine, hPutStr)
+import System.IO (Handle, hClose, hGetLine, hPutStr, hPutStrLn, stderr)
import System.Directory (doesFileExist, doesDirectoryExist)
import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import System.FilePath (takeExtension)
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Text.Hakyll.Util
+-- | Function to log from a chan.
+log :: Chan String -> IO ()
+log logChan = forever (readChan logChan >>= hPutStrLn stderr)
+
-- | General server configuration.
data ServerConfig = ServerConfig { documentRoot :: FilePath
, portNumber :: PortNumber
- } deriving (Show, Eq, Ord)
+ , logChannel :: Chan String
+ }
-- | Custom monad stack.
type Server = ReaderT ServerConfig IO
@@ -96,25 +103,27 @@
let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
else uri
+ create200 = do
+ body <- B.readFile fileName
+ let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
+ ] ++ getMIMEHeader fileName
+ return $ defaultResponse { responseStatusCode = 200
+ , responsePhrase = B.pack "OK"
+ , responseHeaders = (responseHeaders defaultResponse)
+ `M.union` M.fromList headers
+ , responseBody = body
+ }
+
+ -- Called when an error occurs during the creation of a 200 response.
+ create500 e = do writeChan (logChannel config) $ "Internal Error: " ++ show e
+ return $ createErrorResponse 500 (B.pack "Internal Server Error")
+
-- Send back the page if found.
exists <- liftIO $ doesFileExist fileName
- if exists then do response <- liftIO $ catch (create200 fileName) create500
+ if exists then do response <- liftIO $ catch create200 create500
return response
- else return $ createErrorResponse 404 (B.pack "Not Found")
- where create200 fileName = do
- body <- B.readFile fileName
- let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
- ] ++ getMIMEHeader fileName
- return $ defaultResponse { responseStatusCode = 200
- , responsePhrase = B.pack "OK"
- , responseHeaders = (responseHeaders defaultResponse)
- `M.union` M.fromList headers
- , responseBody = body
- }
-
- -- Called when an error occurs during the creation of a 200 response.
- create500 e = do putStrLn $ "Internal Error: " ++ show e
- return $ createErrorResponse 500 (B.pack "Internal Server Error")
+ else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
+ return $ createErrorResponse 404 (B.pack "Not Found")
-- | Get the mime header for a certain filename. This is based on the extension
-- of the given 'FilePath'.
@@ -141,7 +150,8 @@
response <- createResponse request
-- Generate some output.
- liftIO $ putStrLn $ show request ++ " => " ++ show response
+ config <- ask
+ liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response
-- Send the response back to the handle.
liftIO $ putResponse response
@@ -164,15 +174,24 @@
-- directory.
simpleServer :: PortNumber -> FilePath -> IO ()
simpleServer port root = do
- putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."
+ -- Channel to send logs to
+ logChan <- newChan
+
+ let config = ServerConfig { documentRoot = root
+ , portNumber = port
+ , logChannel = logChan
+ }
+
+ -- When a client connects, respond in a separate thread.
+ listen socket = do (handle, _, _) <- accept socket
+ forkIO (runReaderT (respond handle) config)
+ return ()
+
+ -- Handle logging in a separate thread
+ forkIO (log logChan)
+
+ writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
socket <- listenOn (PortNumber port)
forever (listen socket)
- where -- A default configuration.
- config = ServerConfig { documentRoot = root
- , portNumber = port
- }
+ where
- -- When a client connects, respond in a separate thread.
- listen socket = do (handle, _, _) <- accept socket
- forkIO (runReaderT (respond handle) config)
- return ()
diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/Hakyll/Context.hs
@@ -0,0 +1,47 @@
+-- | Module containing various functions to manipulate contexts.
+module Text.Hakyll.Context
+ ( ContextManipulation
+ , renderValue
+ , renderDate
+ ) where
+
+import qualified Data.Map as M
+import qualified Data.ByteString.Lazy.Char8 as B
+
+import System.Locale (defaultTimeLocale)
+import System.FilePath (takeFileName)
+import Text.Regex (subRegex, mkRegex)
+import Text.Template (Context)
+import Data.Time.Format (parseTime, formatTime)
+import Data.Time.Clock (UTCTime)
+import Data.Maybe (fromMaybe)
+
+-- | Type for context manipulating functions.
+type ContextManipulation = Context -> Context
+
+-- | Do something with a value of a context.
+renderValue :: String -- ^ Key of which the value should be copied.
+ -> String -- ^ Key the value should be copied to.
+ -> (B.ByteString -> B.ByteString) -- ^ Function to apply on the value.
+ -> ContextManipulation
+renderValue src dst f context = case M.lookup (B.pack src) context of
+ Nothing -> context
+ (Just value) -> M.insert (B.pack dst) (f value) context
+
+-- | When the context has a key called `path` in a `yyyy-mm-dd-title.extension`
+-- format (default for pages), this function can render the date.
+renderDate :: String -- ^ Key in which the rendered date should be placed.
+ -> String -- ^ Format to use on the date.
+ -> String -- ^ Default value when the date cannot be parsed.
+ -> ContextManipulation
+renderDate key format defaultValue context =
+ M.insert (B.pack key) (B.pack value) context
+ where value = fromMaybe defaultValue pretty
+ pretty = do filePath <- M.lookup (B.pack "path") context
+ let dateString = subRegex (mkRegex "^([0-9]*-[0-9]*-[0-9]*).*")
+ (takeFileName $ B.unpack filePath)
+ "\\1"
+ time <- parseTime defaultTimeLocale
+ "%Y-%m-%d"
+ dateString :: Maybe UTCTime
+ return $ formatTime defaultTimeLocale format time
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
@@ -4,8 +4,10 @@
( toDestination
, toCache
, toURL
+ , removeSpaces
, makeDirectories
, getRecursiveContents
+ , havingExtension
, isCacheValid
, directory
) where
@@ -14,18 +16,31 @@
import System.FilePath
import Control.Monad
+-- | Auxiliary function to remove pathSeparators form the start. We don't deal
+-- with absolute paths here.
+removeLeadingSeparator :: FilePath -> FilePath
+removeLeadingSeparator [] = []
+removeLeadingSeparator p@(x:xs) | x `elem` pathSeparators = xs
+ | otherwise = p
+
-- | Convert a relative filepath to a filepath in the destination (_site).
toDestination :: FilePath -> FilePath
-toDestination path = "_site" path
+toDestination path = "_site" (removeLeadingSeparator path)
-- | Convert a relative filepath to a filepath in the cache (_cache).
toCache :: FilePath -> FilePath
-toCache path = "_cache" path
+toCache path = "_cache" (removeLeadingSeparator path)
-- | Get the url for a given page.
toURL :: FilePath -> FilePath
toURL = flip addExtension ".html" . dropExtension
+-- | Swaps spaces for '-'.
+removeSpaces :: FilePath -> FilePath
+removeSpaces = map swap
+ where swap ' ' = '-'
+ swap x = x
+
-- | Given a path to a file, try to make the path writable by making
-- all directories on the path.
makeDirectories :: FilePath -> IO ()
@@ -46,6 +61,13 @@
else return [path]
return (concat paths)
where isProper = not . (== '.') . head
+
+-- | A filter that takes all file names with a given extension. Prefix the
+-- extension with a dot:
+--
+-- > havingExtension ".markdown" ["index.markdown", "style.css"] == ["index.markdown"]
+havingExtension :: String -> [FilePath] -> [FilePath]
+havingExtension extension = filter ((==) extension . takeExtension)
-- | Perform an IO action on every file in a given directory.
directory :: (FilePath -> IO ()) -> FilePath -> IO ()
diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs
--- a/src/Text/Hakyll/Page.hs
+++ b/src/Text/Hakyll/Page.hs
@@ -2,7 +2,6 @@
( Page
, fromContext
, getValue
- , copyValueWith
, getBody
, readPage
, writePage
@@ -35,17 +34,6 @@
-- found.
getValue :: String -> Page -> B.ByteString
getValue str (Page page) = fromMaybe B.empty $ M.lookup (B.pack str) page
-
--- | Do something with a value of the page.
-copyValueWith :: String -- ^ Key of which the value should be copied.
- -> String -- ^ Key the value should be copied to.
- -> (B.ByteString -> B.ByteString) -- ^ Function to apply on the value.
- -> Page -- ^ Page on which to apply this modification.
- -> Page -- ^ Result.
-copyValueWith src dst f p@(Page page) = case M.lookup (B.pack src) page of
- Nothing -> p
- (Just value) -> Page $ M.insert (B.pack dst) (f value) page
-
-- | Auxiliary function to pack a pair.
packPair :: (String, String) -> (B.ByteString, B.ByteString)
diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs
--- a/src/Text/Hakyll/Render.hs
+++ b/src/Text/Hakyll/Render.hs
@@ -1,8 +1,11 @@
module Text.Hakyll.Render
( depends
, render
+ , renderWith
, renderAndConcat
+ , renderAndConcatWith
, renderChain
+ , renderChainWith
, static
, css
) where
@@ -15,6 +18,7 @@
import System.Directory (copyFile)
import System.IO
+import Text.Hakyll.Context (ContextManipulation)
import Text.Hakyll.Page
import Text.Hakyll.Renderable
import Text.Hakyll.File
@@ -34,21 +38,41 @@
=> FilePath -- ^ Template to use for rendering.
-> a -- ^ Renderable object to render with given template.
-> IO Page -- ^ The body of the result will contain the render.
-render templatePath renderable = do
+render = renderWith id
+
+-- | Render to a Page. This function allows you to manipulate the context
+-- first.
+renderWith :: Renderable a
+ => ContextManipulation -- ^ Manipulation to apply on the context.
+ -> FilePath -- ^ Template to use for rendering.
+ -> a -- ^ Renderable object to render with given template.
+ -> IO Page -- ^ The body of the result will contain the render.
+renderWith manipulation templatePath renderable = do
handle <- openFile templatePath ReadMode
templateString <- liftM B.pack $ hGetContents handle
seq templateString $ hClose handle
- context <- toContext renderable
+ context <- liftM manipulation $ toContext renderable
let body = substitute templateString context
return $ fromContext (M.insert (B.pack "body") body context)
-- | Render each renderable with the given template, then concatenate the
-- result.
renderAndConcat :: Renderable a => FilePath -> [a] -> IO B.ByteString
-renderAndConcat templatePath renderables = foldM concatRender' B.empty renderables
+renderAndConcat = renderAndConcatWith id
+
+-- | Render each renderable with the given template, then concatenate the
+-- result. This function allows you to specify a "ContextManipulation" to
+-- apply on every "Renderable".
+renderAndConcatWith :: Renderable a
+ => ContextManipulation
+ -> FilePath
+ -> [a]
+ -> IO B.ByteString
+renderAndConcatWith manipulation templatePath renderables =
+ foldM concatRender' B.empty renderables
where concatRender' :: Renderable a => B.ByteString -> a -> IO B.ByteString
concatRender' chunk renderable = do
- rendered <- render templatePath renderable
+ rendered <- renderWith manipulation templatePath renderable
let body = getBody rendered
return $ B.append chunk $ body
@@ -56,9 +80,15 @@
-- also write the result to the site destination. This is the preferred way
-- to do general rendering.
renderChain :: Renderable a => [FilePath] -> a -> IO ()
-renderChain templates renderable =
+renderChain = renderChainWith id
+
+-- | A more custom render chain that allows you to specify a
+-- "ContextManipulation" which to apply on the context when it is read first.
+renderChainWith :: Renderable a
+ => ContextManipulation -> [FilePath] -> a -> IO ()
+renderChainWith manipulation templates renderable =
depends (getURL renderable) (getDependencies renderable ++ templates) $
- do initialPage <- toContext renderable
+ do initialPage <- liftM manipulation $ toContext renderable
result <- foldM (flip render) (fromContext initialPage) templates
writePage result
diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs
--- a/src/Text/Hakyll/Tags.hs
+++ b/src/Text/Hakyll/Tags.hs
@@ -1,14 +1,17 @@
-- | Module containing some specialized functions to deal with tags.
+-- This Module follows certain conventions. Stick with them.
module Text.Hakyll.Tags
( readTagMap
, renderTagCloud
+ , renderTagLinks
) where
import qualified Data.Map as M
import qualified Data.ByteString.Lazy.Char8 as B
-import qualified Data.List as L
+import Data.List (intercalate)
import Control.Monad (foldM)
+import Text.Hakyll.Context (ContextManipulation, renderValue)
import Text.Hakyll.Util
import Text.Hakyll.Page
import Control.Arrow (second)
@@ -30,7 +33,7 @@
-> Float -- ^ Biggest font size, in percent.
-> String -- ^ Result of the render.
renderTagCloud tagMap urlFunction minSize maxSize =
- L.intercalate " " $ map renderTag tagCount
+ intercalate " " $ map renderTag tagCount
where renderTag :: (String, Float) -> String
renderTag (tag, count) = " String) -- ^ Function that produces an url for a tag.
+ -> ContextManipulation
+renderTagLinks urlFunction = renderValue "tags" "tags" renderTagLinks'
+ where renderTagLinks' = B.pack . intercalate ", "
+ . map (\t -> link t $ urlFunction t)
+ . map trim . split "," . B.unpack
diff --git a/src/Text/Hakyll/Util.hs b/src/Text/Hakyll/Util.hs
--- a/src/Text/Hakyll/Util.hs
+++ b/src/Text/Hakyll/Util.hs
@@ -2,6 +2,7 @@
( trim
, split
, stripHTML
+ , link
) where
import Data.Char (isSpace)
@@ -26,3 +27,10 @@
split :: String -> String -> [String]
split pattern = filter (not . null)
. splitRegex (mkRegex pattern)
+
+-- | Make a HTML link.
+--
+-- > link "foo" "bar.html" == "foo"
+link :: String -> String -> String
+link text destination = ""
+ ++ text ++ ""