basic stuff is done
This commit is contained in:
parent
db24be34dd
commit
93bfd31abf
2 changed files with 123 additions and 108 deletions
56
app/Main.hs
56
app/Main.hs
|
@ -7,20 +7,21 @@
|
|||
|
||||
module Main where
|
||||
|
||||
import Config
|
||||
import Control.Monad (forM, when)
|
||||
import Data.List (sortOn)
|
||||
import Development.Shake (Action, Rules, (|%>), (~>), (%>))
|
||||
import Development.Shake.FilePath ((</>))
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List (sortOn)
|
||||
import qualified Data.Ord as Ord
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
import Development.Shake (Action, Rules, (%>), (|%>), (~>))
|
||||
import qualified Development.Shake as Shake
|
||||
import Development.Shake.FilePath ((</>))
|
||||
import qualified Development.Shake.FilePath as FP
|
||||
import Config
|
||||
import Templates
|
||||
import Types
|
||||
import Utilities
|
||||
import Templates
|
||||
import Data.Time
|
||||
|
||||
-- target = thing we want
|
||||
-- Rule = pattern of thing being made + actions to produce the thing
|
||||
-- Action = actions to produce a thing
|
||||
|
@ -61,14 +62,16 @@ buildRules = do
|
|||
|
||||
-- make a rule of the pattern outputDir/asset_name which copes from outputDir/../pages
|
||||
assets :: Rules ()
|
||||
assets = map (outputDir </>) assetGlobs |%> \target -> do
|
||||
assets =
|
||||
map (outputDir </>) assetGlobs |%> \target -> do
|
||||
let src = FP.dropDirectory1 target
|
||||
Shake.copyFileChanged src target
|
||||
Shake.putInfo $ "Copied " <> target <> " from " <> src
|
||||
|
||||
|
||||
-- handling typst only because pages should only be typst no reason for backwards compat on that
|
||||
pages :: Rules ()
|
||||
pages = map indexHtmlOutputPath pagePaths |%> \target -> do
|
||||
pages =
|
||||
map indexHtmlOutputPath pagePaths |%> \target -> do
|
||||
let src = indexHtmlTypstSourcePath target
|
||||
let metaSrc = indexHtmlTypstMetaPath target
|
||||
html <- typstToHtml src
|
||||
|
@ -79,15 +82,20 @@ pages = map indexHtmlOutputPath pagePaths |%> \target -> do
|
|||
|
||||
-- there's probably a better way of doing this that allows for the target's origin file extension to get passed in but for now we're doing brute force
|
||||
postsRule :: Rules ()
|
||||
postsRule = map indexHtmlOutputPath postGlobs |%> \target -> do
|
||||
postsRule =
|
||||
map indexHtmlOutputPath postGlobs |%> \target -> do
|
||||
let potentials = indexHtmlSourcePaths target
|
||||
Shake.forP potentials (\path->do
|
||||
Shake.forP
|
||||
potentials
|
||||
( \path -> do
|
||||
exists <- Shake.doesFileExist path
|
||||
when exists
|
||||
when
|
||||
exists
|
||||
( case FP.takeExtension path of
|
||||
".typ" -> typstPost path
|
||||
".md" -> markdownPost path
|
||||
_ -> error $ "invalid file extension for post " <> target)
|
||||
_ -> error $ "invalid file extension for post " <> target
|
||||
)
|
||||
)
|
||||
return ()
|
||||
|
||||
|
@ -103,7 +111,6 @@ typstPost src = do
|
|||
applyTemplateAndWrite "default.html" page target
|
||||
Shake.putInfo $ "Built " <> target <> " from " <> src
|
||||
|
||||
|
||||
markdownPost :: FP.FilePath -> Action ()
|
||||
markdownPost src = do
|
||||
Shake.need [src]
|
||||
|
@ -117,9 +124,11 @@ markdownPost src = do
|
|||
Shake.putInfo $ "Built " <> target <> " from " <> src
|
||||
|
||||
home :: Rules ()
|
||||
home = outputDir </> "index.html" %> \target -> do
|
||||
home =
|
||||
outputDir </> "index.html" %> \target -> do
|
||||
postPaths <- Shake.getDirectoryFiles "" postGlobs
|
||||
posts <- take 3
|
||||
posts <-
|
||||
take 3
|
||||
. sortOn (Ord.Down . postDate)
|
||||
<$> forM postPaths readPost
|
||||
html <- applyTemplate "home.html" $ HM.singleton "posts" posts
|
||||
|
@ -129,7 +138,8 @@ home = outputDir </> "index.html" %> \target -> do
|
|||
Shake.putInfo $ "Built " <> target
|
||||
|
||||
rss :: Rules ()
|
||||
rss = outputDir </> "index.xml" %> \target -> do
|
||||
rss =
|
||||
outputDir </> "index.xml" %> \target -> do
|
||||
postPaths <- Shake.getDirectoryFiles "" postGlobs
|
||||
posts <- sortOn (Ord.Down . postDate) <$> forM postPaths readPost
|
||||
applyTemplateAndWrite "feed.xml" (HM.singleton "posts" posts) target
|
||||
|
@ -148,9 +158,9 @@ readTypstPost postPath = do
|
|||
html <- typstToHtml postPath
|
||||
post <- yamlToPost $ typstMetaPath postPath
|
||||
Shake.putInfo $ "Read " <> postPath
|
||||
return $ post
|
||||
{
|
||||
postContent = Just html,
|
||||
return $
|
||||
post
|
||||
{ postContent = Just html,
|
||||
postLink = Just . T.pack $ "/" <> FP.dropExtension postPath <> "/"
|
||||
}
|
||||
|
||||
|
@ -158,8 +168,8 @@ readMarkdownPost :: FilePath -> Action Post
|
|||
readMarkdownPost postPath = do
|
||||
(post, html) <- markdownToHtml postPath
|
||||
Shake.putInfo $ "Read " <> postPath
|
||||
return $ post
|
||||
{
|
||||
postContent = Just html,
|
||||
return $
|
||||
post
|
||||
{ postContent = Just html,
|
||||
postLink = Just . T.pack $ "/" <> FP.dropExtension postPath <> "/"
|
||||
}
|
||||
|
|
|
@ -1,26 +1,25 @@
|
|||
module Utilities where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Development.Shake.FilePath ((<.>), (</>))
|
||||
import qualified Data.Text as T
|
||||
import Data.Yaml.Aeson
|
||||
import qualified Development.Shake as Shake
|
||||
import qualified Development.Shake.FilePath as Shake
|
||||
import qualified Text.Pandoc as Pandoc
|
||||
import Config
|
||||
import Development.Shake (Action)
|
||||
import Types
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Time
|
||||
import Text.Pandoc (Block (Plain), Meta (..), MetaValue (..), Pandoc (..))
|
||||
import Data.Aeson (Result(Success, Error))
|
||||
import Data.Aeson (Result (Error, Success))
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time
|
||||
import Data.Yaml.Aeson
|
||||
import Development.Shake (Action)
|
||||
import qualified Development.Shake as Shake
|
||||
import Development.Shake.FilePath ((<.>), (</>))
|
||||
import qualified Development.Shake.FilePath as Shake
|
||||
import Text.Pandoc (Block (Plain), Meta (..), MetaValue (..), Pandoc (..))
|
||||
import qualified Text.Pandoc as Pandoc
|
||||
import Types
|
||||
|
||||
indexHtmlOutputPath :: FilePath -> FilePath
|
||||
indexHtmlOutputPath srcPath =
|
||||
outputDir </> Shake.dropExtension srcPath </> "index.html"
|
||||
|
||||
|
||||
-- were applicative shenanigans necessary? no
|
||||
-- but using them felt cool
|
||||
indexHtmlSourcePaths :: FilePath -> [FilePath]
|
||||
|
@ -46,7 +45,6 @@ indexHtmlTypstMetaPath = typstMetaPath . indexHtmlTypstSourcePath
|
|||
typstMetaPath :: FilePath -> FilePath
|
||||
typstMetaPath typstPath = Shake.dropExtension typstPath <.> "yaml"
|
||||
|
||||
|
||||
typstToHtml :: FilePath -> Action Text
|
||||
typstToHtml filePath = do
|
||||
content <- Shake.readFile' filePath
|
||||
|
@ -59,18 +57,24 @@ typstToHtml filePath = do
|
|||
Pandoc.def {Pandoc.readerExtensions = Pandoc.pandocExtensions}
|
||||
writerOptions =
|
||||
Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions}
|
||||
markdownToHtml :: FromJSON a => FilePath -> Action (a, Text)
|
||||
|
||||
markdownToHtml :: (FromJSON a) => FilePath -> Action (a, Text)
|
||||
markdownToHtml filePath = do
|
||||
content <- Shake.readFile' filePath
|
||||
Shake.quietly . Shake.traced "Markdown to HTML" $ do
|
||||
pandoc@(Pandoc meta _) <-
|
||||
runPandoc . Pandoc.readMarkdown readerOptions . T.pack $ content
|
||||
-- WARNING markdown needs to have no whitespace before/after dashes
|
||||
-- print meta
|
||||
meta' <- fromMeta meta
|
||||
html <- runPandoc . Pandoc.writeHtml5String writerOptions $ pandoc
|
||||
return (meta', html)
|
||||
where
|
||||
readerOptions =
|
||||
Pandoc.def {Pandoc.readerExtensions = Pandoc.pandocExtensions}
|
||||
Pandoc.def
|
||||
{ Pandoc.readerStandalone = True,
|
||||
Pandoc.readerExtensions = Pandoc.enableExtension Pandoc.Ext_yaml_metadata_block Pandoc.pandocExtensions
|
||||
}
|
||||
writerOptions =
|
||||
Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions}
|
||||
fromMeta (Meta meta) =
|
||||
|
@ -103,8 +107,9 @@ yamlToPost path = do
|
|||
dateTransform post@(Post {postDate}) = do
|
||||
postDate' <- postDate
|
||||
let postDate'' = dateStrTransform $ T.unpack postDate'
|
||||
Just post {
|
||||
postDate = postDate''
|
||||
Just
|
||||
post
|
||||
{ postDate = postDate''
|
||||
}
|
||||
dateStrTransform date = do
|
||||
date' <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d" date
|
||||
|
|
Loading…
Reference in a new issue