summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Network/Hakyll/SimpleServer.hs114
-rw-r--r--src/Text/Hakyll.hs9
-rw-r--r--src/Text/Hakyll/CompressCSS.hs12
-rw-r--r--src/Text/Hakyll/Context.hs17
-rw-r--r--src/Text/Hakyll/File.hs23
-rw-r--r--src/Text/Hakyll/Page.hs51
-rw-r--r--src/Text/Hakyll/Render.hs49
-rw-r--r--src/Text/Hakyll/Tags.hs52
-rw-r--r--src/Text/Hakyll/Util.hs8
9 files changed, 187 insertions, 148 deletions
diff --git a/src/Network/Hakyll/SimpleServer.hs b/src/Network/Hakyll/SimpleServer.hs
index 017a764..cf4dd07 100644
--- a/src/Network/Hakyll/SimpleServer.hs
+++ b/src/Network/Hakyll/SimpleServer.hs
@@ -78,8 +78,9 @@ defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
-- | 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")
+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.
@@ -89,9 +90,10 @@ 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>"
+ , 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.
@@ -100,48 +102,56 @@ createGetResponse request = do
-- Construct the complete fileName of the requested resource.
config <- ask
let uri = B.unpack (requestURI request)
+ log' = writeChan (logChannel config)
isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
- let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
- else uri
+ 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
- }
+ 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")
+ create500 e = do
+ log' $ "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 create500
- return response
- else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
- return $ createErrorResponse 404 (B.pack "Not Found")
+ if exists
+ then do response <- liftIO $ catch create200 create500
+ return response
+ else do liftIO $ log' $ "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'.
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")
- ]
+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 ()
@@ -152,24 +162,28 @@ respond handle = do
-- Generate some output.
config <- ask
- liftIO $ writeChan (logChannel config) $ show request ++ " => " ++ show response
+ liftIO $ writeChan (logChannel config)
+ $ 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"
+ 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.
@@ -194,5 +208,3 @@ simpleServer port root = do
writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
socket <- listenOn (PortNumber port)
forever (listen socket)
- where
-
diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs
index d34c1c8..7c74b2e 100644
--- a/src/Text/Hakyll.hs
+++ b/src/Text/Hakyll.hs
@@ -28,10 +28,11 @@ build buildFunction = do putStrLn "Generating..."
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 ()
+ where
+ remove' dir = do putStrLn $ "Removing " ++ dir ++ "..."
+ exists <- doesDirectoryExist dir
+ if exists then removeDirectoryRecursive dir
+ else return ()
-- | Show usage information.
help :: IO ()
diff --git a/src/Text/Hakyll/CompressCSS.hs b/src/Text/Hakyll/CompressCSS.hs
index 4b35558..f9a062c 100644
--- a/src/Text/Hakyll/CompressCSS.hs
+++ b/src/Text/Hakyll/CompressCSS.hs
@@ -24,8 +24,10 @@ compressWhitespace = substituteRegex "[ \t\n][ \t\n]*" " "
-- | 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'
+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/Context.hs b/src/Text/Hakyll/Context.hs
index 074c88f..d2c6047 100644
--- a/src/Text/Hakyll/Context.hs
+++ b/src/Text/Hakyll/Context.hs
@@ -38,11 +38,12 @@ renderDate :: String -- ^ Key in which the rendered date should be placed.
-> String -- ^ Default value when the date cannot be parsed.
-> ContextManipulation
renderDate key format defaultValue context = M.insert key value context
- where value = fromMaybe defaultValue pretty
- pretty = do filePath <- M.lookup "path" context
- let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1"
- (takeFileName filePath)
- time <- parseTime defaultTimeLocale
- "%Y-%m-%d"
- dateString :: Maybe UTCTime
- return $ formatTime defaultTimeLocale format time
+ where
+ value = fromMaybe defaultValue pretty
+ pretty = do filePath <- M.lookup "path" context
+ let dateString = substituteRegex "^([0-9]*-[0-9]*-[0-9]*).*" "\\1"
+ (takeFileName filePath)
+ 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
index d8ee8db..0ed91d5 100644
--- a/src/Text/Hakyll/File.hs
+++ b/src/Text/Hakyll/File.hs
@@ -25,8 +25,9 @@ removeLeadingSeparator [] = []
removeLeadingSeparator path
| (head path') `elem` pathSeparators = (tail path')
| otherwise = path'
- where path' = if "$root" `isPrefixOf` path then drop 5 path
- else path
+ where
+ path' = if "$root" `isPrefixOf` path then drop 5 path
+ else path
-- | Convert a relative filepath to a filepath in the destination (_site).
toDestination :: FilePath -> FilePath
@@ -46,21 +47,24 @@ toURL path = if takeExtension path `elem` [".markdown", ".md", ".tex"]
toRoot :: FilePath -> FilePath
toRoot = emptyException . joinPath . map parent . splitPath
. takeDirectory . removeLeadingSeparator
- where parent = const ".."
- emptyException [] = "."
- emptyException x = x
+ where
+ parent = const ".."
+ emptyException [] = "."
+ emptyException x = x
-- | Swaps spaces for '-'.
removeSpaces :: FilePath -> FilePath
removeSpaces = map swap
- where swap ' ' = '-'
- swap x = x
+ 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 ()
makeDirectories path = createDirectoryIfMissing True dir
- where dir = takeDirectory path
+ where
+ dir = takeDirectory path
-- | Get all contents of a directory. Note that files starting with a dot (.)
-- will be ignored.
@@ -75,7 +79,8 @@ getRecursiveContents topdir = do
then getRecursiveContents path
else return [path]
return (concat paths)
- where isProper = not . (== '.') . head
+ where
+ isProper = not . (== '.') . head
-- | A filter that takes all file names with a given extension. Prefix the
-- extension with a dot:
diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs
index c5ddc3a..682f1b9 100644
--- a/src/Text/Hakyll/Page.hs
+++ b/src/Text/Hakyll/Page.hs
@@ -42,7 +42,8 @@ getPageURL (Page page) = fromMaybe (error "No page url") $ M.lookup "url" page
-- | Get the original page path.
getPagePath :: Page -> String
-getPagePath (Page page) = fromMaybe (error "No page path") $ M.lookup "path" page
+getPagePath (Page page) =
+ fromMaybe (error "No page path") $ M.lookup "path" page
-- | Get the body for a certain page. When not defined, the body will be
-- empty.
@@ -56,21 +57,24 @@ writerOptions = defaultWriterOptions
-- | Get a render function for a given extension.
renderFunction :: String -> (String -> String)
renderFunction ".html" = id
-renderFunction ext = writeHtmlString writerOptions .
- readFunction ext defaultParserState
- where readFunction ".markdown" = readMarkdown
- readFunction ".md" = readMarkdown
- readFunction ".tex" = readLaTeX
- readFunction _ = readMarkdown
+renderFunction ext = writeHtmlString writerOptions
+ . readFunction ext defaultParserState
+ where
+ readFunction ".markdown" = readMarkdown
+ readFunction ".md" = readMarkdown
+ readFunction ".tex" = readLaTeX
+ readFunction _ = readMarkdown
-- | Read metadata header from a file handle.
readMetaData :: Handle -> IO [(String, String)]
readMetaData handle = do
line <- hGetLine handle
- if isDelimiter line then return []
- else do others <- readMetaData handle
- return $ (trimPair . break (== ':')) line : others
- where trimPair (key, value) = (trim key, trim $ tail value)
+ if isDelimiter line
+ then return []
+ else do others <- readMetaData handle
+ return $ (trimPair . break (== ':')) line : others
+ where
+ trimPair (key, value) = (trim key, trim $ tail value)
-- | Check if the given string is a metadata delimiter.
isDelimiter :: String -> Bool
@@ -87,10 +91,11 @@ cachePage page@(Page mapping) = do
hPutStrLn handle "---"
hPutStr handle $ getBody page
hClose handle
- where writePair h (k, v) = hPutStr h k >>
- hPutStr h ": " >>
- hPutStr h v >>
- hPutStrLn h ""
+ where
+ writePair h (k, v) = do hPutStr h k
+ hPutStr h ": "
+ hPutStr h v
+ hPutStrLn h ""
-- | Read a page from a file. Metadata is supported, and if the filename
-- has a .markdown extension, it will be rendered using pandoc. Note that
@@ -104,11 +109,12 @@ readPage pagePath = do
-- Read file.
handle <- openFile path ReadMode
line <- hGetLine handle
- (context, body) <- if isDelimiter line
- then do md <- readMetaData handle
- c <- hGetContents handle
- return (md, c)
- else hGetContents handle >>= \b -> return ([], line ++ b)
+ (context, body) <-
+ if isDelimiter line
+ then do md <- readMetaData handle
+ c <- hGetContents handle
+ return (md, c)
+ else hGetContents handle >>= \b -> return ([], line ++ b)
-- Render file
let rendered = (renderFunction $ takeExtension path) body
@@ -123,8 +129,9 @@ readPage pagePath = do
-- Cache if needed
if getFromCache then return () else cachePage page
return page
- where url = toURL pagePath
- cacheFile = toCache url
+ where
+ url = toURL pagePath
+ cacheFile = toCache url
-- Make pages renderable.
instance Renderable Page where
diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs
index 41f76b8..caf0221 100644
--- a/src/Text/Hakyll/Render.hs
+++ b/src/Text/Hakyll/Render.hs
@@ -43,11 +43,12 @@ substitute escaper string context
| "$$" `isPrefixOf` string = escaper ++ substitute' (tail tail')
| "$" `isPrefixOf` string = substituteKey
| otherwise = (head string) : (substitute' tail')
- where tail' = tail string
- (key, rest) = break (not . isAlpha) tail'
- replacement = fromMaybe ('$' : key) $ M.lookup key context
- substituteKey = replacement ++ substitute' rest
- substitute' str = substitute escaper str context
+ where
+ tail' = tail string
+ (key, rest) = break (not . isAlpha) tail'
+ replacement = fromMaybe ('$' : key) $ M.lookup key context
+ substituteKey = replacement ++ substitute' rest
+ substitute' str = substitute escaper str context
-- | "substitute" for use during a chain.
regularSubstitute :: String -> Context -> String
@@ -97,11 +98,12 @@ renderAndConcatWith :: Renderable a
-> IO String
renderAndConcatWith manipulation templatePath renderables =
foldM concatRender' [] renderables
- where concatRender' :: Renderable a => String -> a -> IO String
- concatRender' chunk renderable = do
- rendered <- renderWith manipulation templatePath renderable
- let body = getBody rendered
- return $ chunk ++ body
+ where
+ concatRender' :: Renderable a => String -> a -> IO String
+ concatRender' chunk renderable = do
+ rendered <- renderWith manipulation templatePath renderable
+ let body = getBody rendered
+ return $ chunk ++ body
-- | Chain a render action for a page with a number of templates. This will
-- also write the result to the site destination. This is the preferred way
@@ -125,23 +127,26 @@ writePage page = do
let destination = toDestination url
makeDirectories destination
writeFile destination body
- where url = getURL page
-          -- Substitute $root here, just before writing.
-          body = finalSubstitute (getBody page)
-                             (M.singleton "root" $ toRoot url)
+ where
+ url = getURL page
+    -- Substitute $root here, just before writing.
+    body = finalSubstitute (getBody page)
+                           (M.singleton "root" $ toRoot url)
-- | Mark a certain file as static, so it will just be copied when the site is
-- generated.
static :: FilePath -> IO ()
-static source = depends destination [source]
- (makeDirectories destination >> copyFile source destination)
- where destination = toDestination source
+static source = depends destination [source] action
+ where
+ destination = toDestination source
+ action = do makeDirectories destination
+ copyFile source destination
-- | 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)
+ where
+ destination = toDestination source
+ css' = do contents <- readFile source
+ makeDirectories destination
+ writeFile destination (compressCSS contents)
diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs
index 801b9b1..625584e 100644
--- a/src/Text/Hakyll/Tags.hs
+++ b/src/Text/Hakyll/Tags.hs
@@ -21,10 +21,11 @@ import Control.Arrow (second)
-- 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 $ splitRegex "," $ getValue ("tags") page
- return $ foldr (\t -> M.insertWith (++) t [path]) current tags
+ where
+ addPaths current path = do
+ page <- readPage path
+ let tags = map trim $ splitRegex "," $ 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'.
@@ -34,28 +35,31 @@ renderTagCloud :: M.Map String [FilePath] -- ^ A tag map as produced by 'readTag
-> String -- ^ Result of the render.
renderTagCloud tagMap urlFunction minSize maxSize =
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
+ 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
-- 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' = intercalate ", "
- . map (\t -> link t $ urlFunction t)
- . map trim . splitRegex ","
+ where
+ renderTagLinks' = intercalate ", "
+ . map (\t -> link t $ urlFunction t)
+ . map trim . splitRegex ","
diff --git a/src/Text/Hakyll/Util.hs b/src/Text/Hakyll/Util.hs
index 018c404..858b3fb 100644
--- a/src/Text/Hakyll/Util.hs
+++ b/src/Text/Hakyll/Util.hs
@@ -9,7 +9,8 @@ import Data.Char (isSpace)
-- | Trim a string (drop spaces and tabs at both sides).
trim :: String -> String
trim = reverse . trim' . reverse . trim'
- where trim' = dropWhile isSpace
+ where
+ trim' = dropWhile isSpace
-- | Strip html tags.
stripHTML :: String -> String
@@ -18,8 +19,9 @@ 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
+ where
+ tail' [] = []
+ tail' xs = tail xs
-- | Make a HTML link.
--
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-16 22:37:24 +0000