module Text.Hakyll.Page
( Page
, fromContext
, getValue
, copyValueWith
, getBody
, readPage
, writePage
) where
import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Maybe
import Control.Monad
import System.FilePath
import System.IO
import Text.Hakyll.File
import Text.Hakyll.Util
import Text.Hakyll.Renderable
import Text.Pandoc
data Page = Page (M.Map B.ByteString B.ByteString)
fromContext :: (M.Map B.ByteString B.ByteString) -> Page
fromContext = Page
getValue :: String -> Page -> B.ByteString
getValue str (Page page) = fromMaybe B.empty $ M.lookup (B.pack str) page
copyValueWith :: String
-> String
-> (B.ByteString -> B.ByteString)
-> Page
-> Page
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
packPair :: (String, String) -> (B.ByteString, B.ByteString)
packPair (a, b) = (B.pack a, B.pack b)
getPageURL :: Page -> String
getPageURL (Page page) = B.unpack $ fromMaybe (error "No page url") $ M.lookup (B.pack "url") page
getPagePath :: Page -> String
getPagePath (Page page) = B.unpack $ fromMaybe (error "No page path") $ M.lookup (B.pack "path") page
getBody :: Page -> B.ByteString
getBody (Page page) = fromMaybe B.empty $ M.lookup (B.pack "body") page
writerOptions :: WriterOptions
writerOptions = defaultWriterOptions
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
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)
isDelimiter :: String -> Bool
isDelimiter = L.isPrefixOf "---"
cachePage :: Page -> IO ()
cachePage page@(Page mapping) = do
let destination = toCache $ getURL page
makeDirectories destination
handle <- openFile destination WriteMode
hPutStrLn handle "---"
mapM_ (writePair handle) $ M.toList $ M.delete (B.pack "body") mapping
hPutStrLn handle "---"
B.hPut handle $ getBody page
hClose handle
where writePair h (k, v) = B.hPut h k >>
B.hPut h (B.pack ": ") >>
B.hPut h v >>
hPutStrLn h ""
readPage :: FilePath -> IO Page
readPage pagePath = do
getFromCache <- isCacheValid cacheFile [pagePath]
let path = if getFromCache then cacheFile else pagePath
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)
let rendered = B.pack $ (renderFunction $ takeExtension path) body
seq rendered $ hClose handle
let page = fromContext $ M.fromList $
[ (B.pack "body", rendered)
, packPair ("url", url)
, packPair ("path", pagePath)
] ++ map packPair context
if getFromCache then return () else cachePage page
return page
where url = toURL pagePath
cacheFile = toCache url
writePage :: Page -> IO ()
writePage page = do
let destination = toDestination $ getURL page
makeDirectories destination
B.writeFile destination (getBody page)
instance Renderable Page where
getDependencies = (:[]) . getPagePath
getURL = getPageURL
toContext (Page page) = return page