archive working, site working
This commit is contained in:
parent
0e44c7d427
commit
0a1aef7425
110
Shakefile.hs
110
Shakefile.hs
|
@ -17,7 +17,7 @@ import Text.Pandoc.Class (PandocMonad)
|
||||||
import qualified Text.Pandoc.Class as Pandoc
|
import qualified Text.Pandoc.Class as Pandoc
|
||||||
import Text.Pandoc.Definition ( Pandoc(..)
|
import Text.Pandoc.Definition ( Pandoc(..)
|
||||||
, Block(..)
|
, Block(..)
|
||||||
, Inline
|
, Inline(..)
|
||||||
, nullMeta
|
, nullMeta
|
||||||
, docTitle
|
, docTitle
|
||||||
, docDate
|
, docDate
|
||||||
|
@ -28,6 +28,7 @@ import Text.Pandoc.Options ( ReaderOptions(..)
|
||||||
, ObfuscationMethod(..)
|
, ObfuscationMethod(..)
|
||||||
)
|
)
|
||||||
import qualified Text.Pandoc.Readers as Readers
|
import qualified Text.Pandoc.Readers as Readers
|
||||||
|
import Text.Pandoc.Walk (Walkable(..))
|
||||||
import qualified Text.Pandoc.Writers as Writers
|
import qualified Text.Pandoc.Writers as Writers
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -70,17 +71,25 @@ getBlogpostFromMetas
|
||||||
:: (MonadIO m, MonadFail m) => [Char] -> Bool -> Pandoc -> m BlogPost
|
:: (MonadIO m, MonadFail m) => [Char] -> Bool -> Pandoc -> m BlogPost
|
||||||
getBlogpostFromMetas path toc pandoc@(Pandoc meta _) = do
|
getBlogpostFromMetas path toc pandoc@(Pandoc meta _) = do
|
||||||
eitherBlogpost <- liftIO $ Pandoc.runIO $ do
|
eitherBlogpost <- liftIO $ Pandoc.runIO $ do
|
||||||
title <- inlineToText $ docTitle meta
|
title <- fmap (T.dropEnd 1) $ inlineToText $ docTitle meta
|
||||||
date <- inlineToText $ docDate meta
|
date <- fmap (T.dropAround dateEnvelope) $ inlineToText $ docDate meta
|
||||||
authors <- mapM inlineToText $ docAuthors meta
|
authors <- mapM inlineToText $ docAuthors meta
|
||||||
return $ BlogPost title date authors path toc pandoc
|
return $ BlogPost title date authors path toc pandoc
|
||||||
case eitherBlogpost of
|
case eitherBlogpost of
|
||||||
Left _ -> fail "BAD"
|
Left _ -> fail "BAD"
|
||||||
Right bp -> return bp
|
Right bp -> return bp
|
||||||
|
where
|
||||||
|
dateEnvelope ' ' = True
|
||||||
|
dateEnvelope '\n' = True
|
||||||
|
dateEnvelope '\t' = True
|
||||||
|
dateEnvelope '[' = True
|
||||||
|
dateEnvelope ']' = True
|
||||||
|
dateEnvelope _ = False
|
||||||
|
|
||||||
|
|
||||||
sortByPostDate :: [BlogPost] -> [BlogPost]
|
sortByPostDate :: [BlogPost] -> [BlogPost]
|
||||||
sortByPostDate =
|
sortByPostDate =
|
||||||
sortBy (\a b-> compare (Down (postDate a)) (Down (postDate b)))
|
sortBy (\a b-> compare (postDate b) (postDate a))
|
||||||
|
|
||||||
|
|
||||||
build :: FilePath -> FilePath
|
build :: FilePath -> FilePath
|
||||||
|
@ -103,16 +112,13 @@ buildRules = do
|
||||||
getPost <- mkGetPost
|
getPost <- mkGetPost
|
||||||
getPosts <- mkGetPosts getPost
|
getPosts <- mkGetPosts getPost
|
||||||
getTemplate <- mkGetTemplate
|
getTemplate <- mkGetTemplate
|
||||||
-- build "articles.html" %> \out -> do
|
|
||||||
-- css <- genAllDeps ["//*.css"]
|
|
||||||
-- posts <- getPosts ()
|
|
||||||
-- need $ css <> map postUrl (sortByPostDate posts)
|
|
||||||
-- let titles = toS $ T.intercalate "\n" $ map postTitle posts
|
|
||||||
-- writeFile' out titles
|
|
||||||
build "//*" %> \out -> do
|
build "//*" %> \out -> do
|
||||||
let asset = dropDirectory1 out
|
let asset = dropDirectory1 out
|
||||||
case (takeExtension asset) of
|
case (takeExtension asset) of
|
||||||
".html" -> genHtmlAction getPost getTemplate out
|
".html" -> do
|
||||||
|
if out == siteDir </> "archive.html"
|
||||||
|
then buildArchive getPosts getTemplate out
|
||||||
|
else genHtmlAction getPost getTemplate out
|
||||||
".txt" -> do
|
".txt" -> do
|
||||||
txtExists <- doesFileExist (srcDir </> asset)
|
txtExists <- doesFileExist (srcDir </> asset)
|
||||||
if txtExists
|
if txtExists
|
||||||
|
@ -123,23 +129,62 @@ buildRules = do
|
||||||
".gif" -> compressImage asset
|
".gif" -> compressImage asset
|
||||||
".png" -> compressImage asset
|
".png" -> compressImage asset
|
||||||
_ -> copyFileChanged (srcDir </> asset) out
|
_ -> copyFileChanged (srcDir </> asset) out
|
||||||
-- build "//*.org" %> copy
|
|
||||||
-- build "//*.jpg" %> copy
|
|
||||||
|
|
||||||
copy :: FilePath -> Action ()
|
buildArchive
|
||||||
copy out = do
|
:: (() -> Action [BlogPost])
|
||||||
let src = srcDir </> (dropDirectory1 out)
|
-> (FilePath -> Action Template) -> [Char] -> Action ()
|
||||||
copyFileChanged src out
|
buildArchive getPosts getTemplate out = do
|
||||||
|
css <- genAllDeps ["//*.css"]
|
||||||
|
posts <- fmap sortByPostDate $ getPosts ()
|
||||||
|
need $ css <> map postUrl posts
|
||||||
|
let
|
||||||
|
title :: Text
|
||||||
|
title = "#+title: Posts"
|
||||||
|
articleList = toS $ T.intercalate "\n" $ map postInfo posts
|
||||||
|
fileContent = title <> "\n\n" <> articleList
|
||||||
|
eitherResult <- liftIO $ Pandoc.runIO $ Readers.readOrg (def { readerStandalone = True }) (toS fileContent)
|
||||||
|
bp <- case eitherResult of
|
||||||
|
Left _ -> fail "BAD"
|
||||||
|
Right pandoc -> getBlogpostFromMetas out False pandoc
|
||||||
|
innerHtml <- genHtml bp
|
||||||
|
template <- getTemplate ("templates" </> "main.mustache")
|
||||||
|
let htmlContent =
|
||||||
|
renderMustache template
|
||||||
|
$ object [ "title" .= postTitle bp
|
||||||
|
, "authors" .= postAuthors bp
|
||||||
|
, "date" .= postDate bp
|
||||||
|
, "body" .= innerHtml
|
||||||
|
]
|
||||||
|
writeFile' out (toS htmlContent)
|
||||||
|
|
||||||
|
postInfo :: BlogPost -> Text
|
||||||
|
postInfo bp =
|
||||||
|
"- " <> date <> ": " <> orglink
|
||||||
|
where
|
||||||
|
date = T.takeWhile (/= ' ') (postDate bp)
|
||||||
|
url = toS (dropDirectory1 (postUrl bp))
|
||||||
|
orglink = "[[file:" <> url <> "][" <> (postTitle bp) <> "]]"
|
||||||
|
|
||||||
|
replaceLinks :: Pandoc -> Pandoc
|
||||||
|
replaceLinks = walk replaceOrgLink
|
||||||
|
where
|
||||||
|
replaceOrgLink :: Inline -> Inline
|
||||||
|
replaceOrgLink lnk@(Link attr inl (url,txt)) =
|
||||||
|
if takeExtension (toS url) == ".org"
|
||||||
|
then Link attr inl ((toS (toS url -<.> ".html")),txt)
|
||||||
|
else lnk
|
||||||
|
replaceOrgLink x = x
|
||||||
|
|
||||||
genHtml :: (MonadIO m, MonadFail m) => BlogPost -> m Text
|
genHtml :: (MonadIO m, MonadFail m) => BlogPost -> m Text
|
||||||
genHtml bp = do
|
genHtml bp = do
|
||||||
|
let htmlBody = replaceLinks (postBody bp)
|
||||||
eitherHtml <- liftIO $
|
eitherHtml <- liftIO $
|
||||||
Pandoc.runIO $
|
Pandoc.runIO $
|
||||||
Writers.writeHtml5String
|
Writers.writeHtml5String
|
||||||
(def { writerTableOfContents = (postToc bp)
|
(def { writerTableOfContents = (postToc bp)
|
||||||
, writerEmailObfuscation = ReferenceObfuscation
|
, writerEmailObfuscation = ReferenceObfuscation
|
||||||
})
|
})
|
||||||
(postBody bp)
|
htmlBody
|
||||||
case eitherHtml of
|
case eitherHtml of
|
||||||
Left _ -> fail "BAD"
|
Left _ -> fail "BAD"
|
||||||
Right innerHtml -> return innerHtml
|
Right innerHtml -> return innerHtml
|
||||||
|
@ -196,7 +241,7 @@ allAsciiAction = do
|
||||||
let allAsciiFiles = map (-<.> "txt") allOrgFiles
|
let allAsciiFiles = map (-<.> "txt") allOrgFiles
|
||||||
need (map build allAsciiFiles)
|
need (map build allAsciiFiles)
|
||||||
|
|
||||||
compressImage :: CmdResult b => FilePath -> Action b
|
compressImage :: FilePath -> Action ()
|
||||||
compressImage img = do
|
compressImage img = do
|
||||||
let src = srcDir </> img
|
let src = srcDir </> img
|
||||||
dst = siteDir </> img
|
dst = siteDir </> img
|
||||||
|
@ -205,28 +250,21 @@ compressImage img = do
|
||||||
dirExists <- doesDirectoryExist dir
|
dirExists <- doesDirectoryExist dir
|
||||||
when (not dirExists) $
|
when (not dirExists) $
|
||||||
command [] "mkdir" ["-p", dir]
|
command [] "mkdir" ["-p", dir]
|
||||||
command [] "convert" [src
|
command_ [] "convert" [ src
|
||||||
, "-strip"
|
, "-strip"
|
||||||
, "-resize","320x320>"
|
, "-resize","320x320>"
|
||||||
, "-interlace","Plane"
|
, "-interlace","Plane"
|
||||||
, "-quality","85"
|
, "-quality","85"
|
||||||
, "-define","filter:blur=0.75"
|
, "-define","filter:blur=0.75"
|
||||||
, "-filter","Gaussian"
|
, "-filter","Gaussian"
|
||||||
, "-ordered-dither","o4x4,4"
|
, "-ordered-dither","o4x4,4"
|
||||||
, dst ]
|
, dst ]
|
||||||
|
|
||||||
allRule :: Rules ()
|
allRule :: Rules ()
|
||||||
allRule =
|
allRule =
|
||||||
phony "all" $ do
|
phony "all" $ do
|
||||||
allAssets <- filter (/= ".DS_Store") <$> getDirectoryFiles srcDir ["//*.*"]
|
allAssets <- filter (/= ".DS_Store") <$> getDirectoryFiles srcDir ["//*.*"]
|
||||||
need (map build allAssets)
|
need (map build $ allAssets <> ["archive.html"])
|
||||||
-- forM_ allAssets $ \asset ->
|
|
||||||
-- case (takeExtension asset) of
|
|
||||||
-- ".jpg" -> compressImage asset
|
|
||||||
-- ".jpeg" -> compressImage asset
|
|
||||||
-- ".gif" -> compressImage asset
|
|
||||||
-- ".png" -> compressImage asset
|
|
||||||
-- _ -> copyFileChanged (srcDir </> asset) (siteDir </> asset)
|
|
||||||
allHtmlAction
|
allHtmlAction
|
||||||
allAsciiAction
|
allAsciiAction
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue