hakyll 0.3.2 → 0.4
raw patch · 8 files changed
+182/−55 lines, 8 filesdep +old-localedep +timedep ~pandoc
Dependencies added: old-locale, time
Dependency ranges changed: pandoc
Files
- hakyll.cabal +8/−5
- src/Network/Hakyll/SimpleServer.hs +47/−28
- src/Text/Hakyll/Context.hs +47/−0
- src/Text/Hakyll/File.hs +24/−2
- src/Text/Hakyll/Page.hs +0/−12
- src/Text/Hakyll/Render.hs +36/−6
- src/Text/Hakyll/Tags.hs +12/−2
- src/Text/Hakyll/Util.hs +8/−0
hakyll.cabal view
@@ -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
src/Network/Hakyll/SimpleServer.hs view
@@ -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 ()
+ src/Text/Hakyll/Context.hs view
@@ -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
src/Text/Hakyll/File.hs view
@@ -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 ()
src/Text/Hakyll/Page.hs view
@@ -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)
src/Text/Hakyll/Render.hs view
@@ -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
src/Text/Hakyll/Tags.hs view
@@ -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) = "<a style=\"font-size: " ++ sizeTag count ++ "\" href=\""@@ -49,3 +52,10 @@ tagCount :: [(String, Float)] tagCount = map (second $ fromIntegral . length) $ M.toList tagMap +-- Render all tags to links.+renderTagLinks :: (String -> 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
src/Text/Hakyll/Util.hs view
@@ -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" == "<a href='bar.html'>foo</a>"+link :: String -> String -> String+link text destination = "<a href=\"" ++ destination ++ "\">"+ ++ text ++ "</a>"