hakyll 0.2 → 0.3

raw patch · 11 files changed

+473/−101 lines, 11 filesdep +mtldep +networkdep +regex-compatdep ~bytestringdep ~containersdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, network, regex-compat

Dependency ranges changed: bytestring, containers, directory, filepath, template

API changes (from Hackage documentation)

Files

• hakyll.cabal +18/−5
• src/Network/Hakyll/SimpleServer.hs +178/−0
• src/Text/Hakyll.hs +51/−0
• src/Text/Hakyll/CompressCSS.hs +35/−0
• src/Text/Hakyll/File.hs +60/−0
• src/Text/Hakyll/Page.hs +36/−13
• src/Text/Hakyll/Render.hs +18/−13
• src/Text/Hakyll/Renderable.hs +2/−2
• src/Text/Hakyll/Renderables.hs +6/−7
• src/Text/Hakyll/Tags.hs +51/−0
• src/Text/Hakyll/Util.hs +18/−61

@@ -1,5 +1,5 @@ Name:           hakyll-Version:        0.2+Version:        0.3  Synopsis:       A simple static site generator library. Description:@@ -7,7 +7,7 @@   creating blogs. Author:         Jasper Van der Jeugt Maintainer:     jaspervdj@gmail.com-Homepage:       http://github.com/jaspervdj/Hakyll+Homepage:       http://jaspervdj.be/hakyll License:        BSD3 License-File:   LICENSE Category:       Text@@ -18,10 +18,23 @@ library   ghc-options: -Wall   hs-source-dirs: src/-  build-depends:   base >= 4 && < 5, template, filepath, directory, containers, bytestring,-                   pandoc >= 1-  exposed-modules: Text.Hakyll.Render+  build-depends:   base >= 4 && < 5,+                   template >= 0.1,+                   filepath >= 1.1,+                   directory >= 1,+                   containers >= 0.1,+                   bytestring >= 0.9,+                   pandoc >= 1,+                   regex-compat >= 0.92,+                   network >= 2,+                   mtl >= 1.1+  exposed-modules: Text.Hakyll+                   Text.Hakyll.Render                    Text.Hakyll.Renderable                    Text.Hakyll.Renderables+                   Text.Hakyll.CompressCSS+                   Text.Hakyll.File                    Text.Hakyll.Page                    Text.Hakyll.Util+                   Text.Hakyll.Tags+                   Network.Hakyll.SimpleServer

@@ -0,0 +1,178 @@+-- | Module containing a small, simple http file server for testing and preview+--   purposes.+module Network.Hakyll.SimpleServer+    ( simpleServer+    ) where++import Network+import Control.Monad (forever, mapM_)+import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)+import System.IO (Handle, hClose, hGetLine, hPutStr)+import System.Directory (doesFileExist, doesDirectoryExist)+import Control.Concurrent (forkIO)+import System.FilePath (takeExtension)+import qualified Data.ByteString.Char8 as B+import qualified Data.Map as M++import Text.Hakyll.Util++-- | General server configuration.+data ServerConfig = ServerConfig { documentRoot :: FilePath+                                 , portNumber :: PortNumber+                                 } deriving (Show, Eq, Ord)++-- | Custom monad stack.+type Server = ReaderT ServerConfig IO++-- | Simple representation of a HTTP request.+data Request = Request { requestMethod :: B.ByteString+                       , requestURI :: B.ByteString+                       , requestVersion :: B.ByteString+                       } deriving (Ord, Eq)++instance Show Request where+    show request =  (B.unpack $ requestMethod request) ++ " "+                 ++ (B.unpack $ requestURI request) ++ " "+                 ++ (B.unpack $ requestVersion request)++-- | Read a HTTP request from a 'Handle'. For now, this will ignore the request+--   headers and body.+readRequest :: Handle -> Server Request+readRequest handle = do+    requestLine <- liftIO $ hGetLine handle+    let [method, uri, version] = map trim $ split " " requestLine+    return $ Request { requestMethod = B.pack method+                     , requestURI = B.pack uri+                     , requestVersion = B.pack version+                     }++-- | Simple representation of the HTTP response we send back.+data Response = Response { responseVersion :: B.ByteString+                         , responseStatusCode :: Int+                         , responsePhrase :: B.ByteString+                         , responseHeaders :: M.Map B.ByteString B.ByteString+                         , responseBody :: B.ByteString+                         } deriving (Ord, Eq)++instance Show Response where+    show response =  (B.unpack $ responseVersion response) ++ " "+                  ++ (show $ responseStatusCode response) ++ " "+                  ++ (B.unpack $ responsePhrase response)++-- | A default response.+defaultResponse :: Response+defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"+                           , responseStatusCode = 0+                           , responsePhrase = B.empty+                           , responseHeaders = M.empty+                           , responseBody = B.empty+                           }++-- | Create a response for a given HTTP request.+createResponse :: Request -> Server Response+createResponse request | requestMethod request == B.pack "GET" = createGetResponse request+                       | otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")++-- | Create a simple error response.+createErrorResponse :: Int          -- ^ Error code.+                    -> B.ByteString -- ^ Error phrase.+                    -> Response     -- ^ Result.+createErrorResponse statusCode phrase = defaultResponse+    { responseStatusCode = statusCode+    , responsePhrase = phrase+    , responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")+    , responseBody = B.pack $  "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"+                            ++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"+                            ++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"+    }++-- | Create a simple get response.+createGetResponse :: Request -> Server Response+createGetResponse request = do+    -- Construct the complete fileName of the requested resource.+    config <- ask+    let uri = B.unpack (requestURI request)+    isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri+    let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"+                                                           else uri++    -- Send back the page if found.+    exists <- liftIO $ doesFileExist fileName+    if exists then do response <- liftIO $ catch (create200 fileName) 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")++-- | Get the mime header for a certain filename. This is based on the extension+--   of the given 'FilePath'.+getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]+getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack x)]+                                        Nothing  -> []+    where result = lookup (takeExtension fileName) [ (".css", "text/css")+                                                   , (".gif", "image/gif")+                                                   , (".htm", "text/html")+                                                   , (".html", "text/html")+                                                   , (".jpeg", "image/jpeg")+                                                   , (".jpg", "image/jpeg")+                                                   , (".js", "text/javascript")+                                                   , (".png", "image/png")+                                                   , (".txt", "text/plain")+                                                   , (".xml", "text/xml")+                                                   ]++-- | Respond to an incoming request.+respond :: Handle -> Server ()+respond handle = do+    -- Read the request and create a response.+    request <- readRequest handle+    response <- createResponse request++    -- Generate some output.+    liftIO $ putStrLn $ show request ++ " => " ++ show response++    -- Send the response back to the handle.+    liftIO $ putResponse response+    where putResponse response = do B.hPutStr handle $ B.intercalate (B.pack " ")+                                          [ responseVersion response+                                          , B.pack $ show $ responseStatusCode response+                                          , responsePhrase response+                                          ]+                                    hPutStr handle "\r\n"+                                    mapM_ putHeader (M.toList $ responseHeaders response)+                                    hPutStr handle "\r\n"+                                    B.hPutStr handle $ responseBody response+                                    hPutStr handle "\r\n"+                                    hClose handle++          putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "+                                                        `B.append` value `B.append` B.pack "\r\n"++-- | Start a simple http server on the given 'PortNumber', serving the given+--   directory.+simpleServer :: PortNumber -> FilePath -> IO ()+simpleServer port root = do+    putStrLn $ "Starting hakyll server on port " ++ show port ++ "..."+    socket <- listenOn (PortNumber port)+    forever (listen socket)+    where -- A default configuration.+          config = ServerConfig { documentRoot = root+                                , portNumber = port+                                }++          -- When a client connects, respond in a separate thread.+          listen socket = do (handle, _, _) <- accept socket+                             forkIO (runReaderT (respond handle) config)+                             return ()

@@ -0,0 +1,51 @@+module Text.Hakyll+    ( hakyll+    ) where++import Network.Hakyll.SimpleServer (simpleServer)++import System.Environment (getArgs, getProgName)+import System.Directory (doesDirectoryExist, removeDirectoryRecursive)++-- | Main function to run hakyll.+hakyll :: IO () -> IO ()+hakyll buildFunction = do+    args <- getArgs+    case args of []             -> build buildFunction+                 ["clean"]      -> clean+                 ["preview", p] -> build buildFunction >> server (read p)+                 ["preview"]    -> build buildFunction >> server 8000+                 ["server", p]  -> server (read p)+                 ["server"]     -> server 8000+                 _              -> help++-- | Build the site.+build :: IO () -> IO ()+build buildFunction = do putStrLn "Generating..."+                         buildFunction++-- | Clean up directories.+clean :: IO ()+clean = do remove' "_cache"+           remove' "_site"+    where remove' dir = do putStrLn $ "Removing " ++ dir ++ "..."+                           exists <- doesDirectoryExist dir+                           if exists then removeDirectoryRecursive dir+                                     else return ()++-- | Show usage information.+help :: IO ()+help = do+    name <- getProgName+    putStrLn $  "This is a hakyll site generator program. You should always\n"+             ++ "run it from the project root directory.\n"+             ++ "\n"+             ++ "Usage:\n"+             ++ name ++ "                 Generate the site.\n"+             ++ name ++ " clean           Clean up and remove cache.\n"+             ++ name ++ " help            Show this message.\n"+             ++ name ++ " preview [port]  Generate site, then start a server.\n"+             ++ name ++ " server [port]   Run a local test server.\n"++server :: Integer -> IO ()+server p = do simpleServer (fromIntegral $ p) "_site"

@@ -0,0 +1,35 @@+module Text.Hakyll.CompressCSS+    ( compressCSS+    ) where++import Data.List (isPrefixOf)+import Text.Regex (subRegex, mkRegex)++-- | subRegex with arguments flipped for easy function composition.+subRegex' :: String -> String -> String -> String+subRegex' pattern replacement str = subRegex (mkRegex pattern) str replacement++-- | Compress CSS to speed up your site.+compressCSS :: String -> String+compressCSS = compressSeparators+            . compressWhitespace+            . stripComments++-- | Compresses certain forms of separators.+compressSeparators :: String -> String+compressSeparators = subRegex' ";\\s*}" "}" +                   . subRegex' "\\s*([{};:])\\s*" "\\1"+                   . subRegex' ";;*" ";"++-- | Compresses all whitespace.+compressWhitespace :: String -> String+compressWhitespace = subRegex' "\\s\\s*" " "++-- | Function that strips CSS comments away.+stripComments :: String -> String+stripComments [] = []+stripComments str | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str+                  | otherwise = (head str) : (stripComments $ tail str)+    where eatComments str' | null str' = []+                           | isPrefixOf "*/" str' = drop 2 str'+                           | otherwise = eatComments $ tail str'

@@ -0,0 +1,60 @@+-- | A module containing various function for manipulating and examinating+--   files and directories.+module Text.Hakyll.File+    ( toDestination+    , toCache+    , toURL+    , makeDirectories+    , getRecursiveContents+    , isCacheValid+    , directory+    ) where++import System.Directory+import System.FilePath+import Control.Monad++-- | Convert a relative filepath to a filepath in the destination (_site).+toDestination :: FilePath -> FilePath+toDestination path = "_site" </> path++-- | Convert a relative filepath to a filepath in the cache (_cache).+toCache :: FilePath -> FilePath+toCache path = "_cache" </> path++-- | Get the url for a given page.+toURL :: FilePath -> FilePath+toURL = flip addExtension ".html" . dropExtension++-- | Given a path to a file, try to make the path writable by making+--   all directories on the path.+makeDirectories :: FilePath -> IO ()+makeDirectories path = createDirectoryIfMissing True dir+    where dir = takeDirectory path++-- | Get all contents of a directory. Note that files starting with a dot (.)+--   will be ignored.+getRecursiveContents :: FilePath -> IO [FilePath]+getRecursiveContents topdir = do+    names <- getDirectoryContents topdir+    let properNames = filter isProper names+    paths <- forM properNames $ \name -> do+        let path = topdir </> name+        isDirectory <- doesDirectoryExist path+        if isDirectory+            then getRecursiveContents path+            else return [path]+    return (concat paths)+    where isProper = not . (== '.') . head++-- | Perform an IO action on every file in a given directory.+directory :: (FilePath -> IO ()) -> FilePath -> IO ()+directory action dir = getRecursiveContents dir >>= mapM_ action++-- | Check is a cache file is still valid.+isCacheValid :: FilePath -> [FilePath] -> IO Bool+isCacheValid cache depends = doesFileExist cache >>= \exists ->+    if not exists then return False+                  else do dependsModified <- (mapM getModificationTime depends) >>= return . maximum+                          cacheModified <- getModificationTime cache+                          return (cacheModified >= dependsModified)

@@ -1,9 +1,11 @@ module Text.Hakyll.Page -    ( Page,-      fromContext,-      getBody,-      readPage,-      writePage+    ( Page+    , fromContext+    , getValue+    , copyValueWith+    , getBody+    , readPage+    , writePage     ) where  import qualified Data.Map as M@@ -15,6 +17,7 @@ import System.FilePath import System.IO +import Text.Hakyll.File import Text.Hakyll.Util import Text.Hakyll.Renderable import Text.Pandoc@@ -27,18 +30,35 @@ fromContext :: (M.Map B.ByteString B.ByteString) -> Page fromContext = Page +-- | Obtain a value from a page. Will resturn an empty string when nothing is+--   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) packPair (a, b) = (B.pack a, B.pack b)  -- | Get the URL for a certain page. This should always be defined. If---   not, it will return trash.html.+--   not, it will error. getPageURL :: Page -> String-getPageURL (Page page) =-    let result = M.lookup (B.pack "url") page-    in case result of (Just url) -> B.unpack url-                      Nothing    -> error "URL is not defined."+getPageURL (Page page) = B.unpack $ fromMaybe (error "No page url") $ M.lookup (B.pack "url") page +-- | Get the original page path.+getPagePath :: Page -> String+getPagePath (Page page) = B.unpack $ fromMaybe (error "No page path") $ M.lookup (B.pack "path") page+ -- | Get the body for a certain page. When not defined, the body will be --   empty. getBody :: Page -> B.ByteString@@ -109,7 +129,10 @@     let rendered = B.pack $ (renderFunction $ takeExtension path) body     seq rendered $ hClose handle     let page = fromContext $ M.fromList $-            [(B.pack "body", rendered), packPair ("url", url)] ++ map packPair context+            [ (B.pack "body", rendered)+            , packPair ("url", url)+            , packPair ("path", pagePath)+            ] ++ map packPair context      -- Cache if needed     if getFromCache then return () else cachePage page@@ -126,6 +149,6 @@  -- Make pages renderable. instance Renderable Page where-    getDependencies = (:[]) . flip addExtension ".html" . dropExtension . getPageURL+    getDependencies = (:[]) . getPagePath     getURL = getPageURL-    toContext (Page mapping) = return mapping+    toContext (Page page) = return page

@@ -1,23 +1,24 @@ module Text.Hakyll.Render -    ( depends,-      render,-      renderAndConcat,-      renderChain,-      static,-      staticDirectory+    ( depends+    , render+    , renderAndConcat+    , renderChain+    , static+    , css     ) where  import Text.Template hiding (render) import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M-import Control.Monad+import Control.Monad (unless, liftM, foldM) -import System.Directory+import System.Directory (copyFile) import System.IO  import Text.Hakyll.Page import Text.Hakyll.Renderable-import Text.Hakyll.Util+import Text.Hakyll.File+import Text.Hakyll.CompressCSS  -- | Execute an IO action only when the cache is invalid. depends :: FilePath -- ^ File to be rendered or created.@@ -68,7 +69,11 @@         (makeDirectories destination >> copyFile source destination)     where destination = toDestination source --- | Mark a whole directory as static.-staticDirectory :: FilePath -> IO ()-staticDirectory dir = -    getRecursiveContents dir >>= mapM_ static+-- | Render a css file, compressing it.+css :: FilePath -> IO ()+css source = depends destination [source] css'+    where destination = toDestination source+          css' = do h <- openFile source ReadMode+                    contents <- hGetContents h+                    makeDirectories destination+                    writeFile destination (compressCSS contents)

@@ -2,8 +2,8 @@     ( Renderable(toContext, getDependencies, getURL)     ) where -import System.FilePath-import Text.Template+import System.FilePath (FilePath)+import Text.Template (Context)  -- | A class for datatypes that can be rendered to pages. class Renderable a where

@@ -1,17 +1,16 @@ module Text.Hakyll.Renderables-    ( CustomPage,-      createCustomPage,-      PagePath,-      createPagePath+    ( CustomPage+    , createCustomPage+    , PagePath+    , createPagePath     ) where -import System.FilePath+import System.FilePath (FilePath) import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M-import Control.Monad-import Text.Hakyll.Util import Text.Hakyll.Page import Text.Hakyll.Renderable+import Text.Hakyll.File  -- | A custom page. data CustomPage = CustomPage 

@@ -0,0 +1,51 @@+-- | Module containing some specialized functions to deal with tags.+module Text.Hakyll.Tags+    ( readTagMap+    , renderTagCloud+    ) where++import qualified Data.Map as M+import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.List as L+import Control.Monad (foldM)++import Text.Hakyll.Util+import Text.Hakyll.Page+import Control.Arrow (second)++-- | Read a tag map. This creates a map from tags to page paths. This function+--   assumes the tags are located in the `tags` metadata field, separated by+--   commas.+readTagMap :: [FilePath] -> IO (M.Map String [FilePath])+readTagMap paths = foldM addPaths M.empty paths+    where addPaths current path = do+            page <- readPage path+            let tags = map trim $ split "," $ B.unpack $ getValue ("tags") page+            return $ foldr (\t -> M.insertWith (++) t [path]) current tags++-- | Render a tag cloud.+renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTagMap'.+               -> (String -> String) -- ^ Function that produces an url for a tag.+               -> Float -- ^ Smallest font size, in percent.+               -> Float -- ^ Biggest font size, in percent.+               -> String -- ^ Result of the render.+renderTagCloud tagMap urlFunction minSize maxSize =+    L.intercalate " " $ map renderTag tagCount+    where renderTag :: (String, Float) -> String+          renderTag (tag, count) =  "<a style=\"font-size: "+                                 ++ sizeTag count ++ "\" href=\""+                                 ++ urlFunction tag ++ "\">"+                                 ++ tag ++ "</a>"++          sizeTag :: Float -> String+          sizeTag count = show size' ++ "%"+                where size' :: Int+                      size' = floor (minSize + (relative count) * (maxSize - minSize))+          +          minCount = minimum $ map snd $ tagCount+          maxCount = maximum $ map snd $ tagCount+          relative count = (count - minCount) / (maxCount - minCount)++          tagCount :: [(String, Float)]+          tagCount = map (second $ fromIntegral . length) $ M.toList tagMap+

@@ -1,71 +1,28 @@ module Text.Hakyll.Util -    ( toDestination,-      toCache,-      toURL,-      makeDirectories,-      getRecursiveContents,-      trim,-      split,-      isCacheValid+    ( trim+    , split+    , stripHTML     ) where -import System.Directory-import System.FilePath-import Control.Monad-import Data.Char-import Data.List---- | Convert a relative filepath to a filepath in the destination (_site).-toDestination :: FilePath -> FilePath-toDestination path = "_site" </> path---- | Convert a relative filepath to a filepath in the cache (_cache).-toCache :: FilePath -> FilePath-toCache path = "_cache" </> path---- | Get the url for a given page.-toURL :: FilePath -> FilePath-toURL = flip addExtension ".html" . dropExtension---- | Given a path to a file, try to make the path writable by making---   all directories on the path.-makeDirectories :: FilePath -> IO ()-makeDirectories path = createDirectoryIfMissing True dir-    where dir = takeDirectory path---- | Get all contents of a directory. Note that files starting with a dot (.)---   will be ignored.-getRecursiveContents :: FilePath -> IO [FilePath]-getRecursiveContents topdir = do-    names <- getDirectoryContents topdir-    let properNames = filter isProper names-    paths <- forM properNames $ \name -> do-        let path = topdir </> name-        isDirectory <- doesDirectoryExist path-        if isDirectory-            then getRecursiveContents path-            else return [path]-    return (concat paths)-    where isProper = not . (== '.') . head+import Data.Char (isSpace)+import Text.Regex (splitRegex, mkRegex)  -- | Trim a string (drop spaces and tabs at both sides). trim :: String -> String trim = reverse . trim' . reverse . trim'     where trim' = dropWhile isSpace --- | Split a list at a certain element.-split :: (Eq a) => a -> [a] -> [[a]]-split element = unfoldr splitOnce-    where splitOnce l = let r = break (== element) l-                        in case r of ([], []) -> Nothing-                                     (x, xs) -> if null xs-                                                    then Just (x, [])-                                                    else Just (x, tail xs)+-- | Strip html tags.+stripHTML :: String -> String+stripHTML []  = []+stripHTML str = let (beforeTag, rest) = break (== '<') str+                    (_, afterTag)     = break (== '>') rest+                in beforeTag ++ (stripHTML $ tail' afterTag)+    -- We need a failsafe tail function.+    where tail' [] = []+          tail' xs = tail xs --- | Check is a cache file is still valid.-isCacheValid :: FilePath -> [FilePath] -> IO Bool-isCacheValid cache depends = doesFileExist cache >>= \exists ->-    if not exists then return False-                  else do dependsModified <- (mapM getModificationTime depends) >>= return . maximum-                          cacheModified <- getModificationTime cache-                          return (cacheModified >= dependsModified)+-- | Split a list at a certain element.+split :: String -> String -> [String]+split pattern = filter (not . null)+              . splitRegex (mkRegex pattern)