" ++ (B.unpack phrase) ++ "
" + } + +-- | 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 () diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll.hs @@ -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" diff --git a/src/Text/Hakyll/CompressCSS.hs b/src/Text/Hakyll/CompressCSS.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/CompressCSS.hs @@ -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' diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/File.hs @@ -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) 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 @@ -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 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,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) diff --git a/src/Text/Hakyll/Renderable.hs b/src/Text/Hakyll/Renderable.hs --- a/src/Text/Hakyll/Renderable.hs +++ b/src/Text/Hakyll/Renderable.hs @@ -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 diff --git a/src/Text/Hakyll/Renderables.hs b/src/Text/Hakyll/Renderables.hs --- a/src/Text/Hakyll/Renderables.hs +++ b/src/Text/Hakyll/Renderables.hs @@ -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 diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hakyll/Tags.hs @@ -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) = "" + ++ tag ++ "" + + 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 + 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 @@ -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)