221 lines
8.7 KiB
Haskell
221 lines
8.7 KiB
Haskell
module Main (main) where
|
|
|
|
import Prelude
|
|
|
|
import Hakyll
|
|
|
|
import Data.Bool
|
|
import Data.List qualified as List
|
|
import Data.Maybe
|
|
|
|
import System.FilePath
|
|
import System.FilePath.Glob qualified as Glob
|
|
|
|
import Data.Yaml qualified as Yaml
|
|
|
|
import Data.Map (Map)
|
|
import Data.Map qualified as Map
|
|
|
|
import Control.Monad
|
|
import Control.Monad.Reader.Class
|
|
import Control.Monad.Trans.Maybe
|
|
import Control.Monad.Trans.Reader (Reader, runReader)
|
|
|
|
import Control.Applicative
|
|
|
|
import Data.Text.Lazy qualified as Lazy (Text)
|
|
import Data.Text.Lazy.IO qualified as LT
|
|
import Text.Megaparsec (Parsec, ParsecT)
|
|
import Text.Megaparsec qualified as MP
|
|
import Text.Megaparsec.Char qualified as MP
|
|
|
|
import Data.Text (Text)
|
|
import Data.Text qualified as T
|
|
|
|
import Control.Exception
|
|
import System.IO.Error
|
|
|
|
import Data.Void
|
|
|
|
config :: Configuration
|
|
config =
|
|
defaultConfiguration
|
|
{ destinationDirectory = "public"
|
|
}
|
|
|
|
routeAsFilePath :: (FilePath -> FilePath) -> Routes
|
|
routeAsFilePath f = customRoute $ f . toFilePath
|
|
|
|
stripPathPrefix :: FilePath -> (FilePath -> FilePath)
|
|
stripPathPrefix (splitDirectories -> prefix) =
|
|
joinPath . (\x -> fromMaybe x $ List.stripPrefix prefix x) . splitDirectories
|
|
|
|
handleIf :: Exception e => (e -> Bool) -> (e -> IO a) -> IO a -> IO a
|
|
handleIf predicate handler = handle $ \exc -> bool throwIO handler (predicate exc) exc
|
|
|
|
main :: IO ()
|
|
main = hakyllWith config $ do
|
|
frontendManifest <-
|
|
preprocess $
|
|
Yaml.decodeFileThrow @_ @(Map String [FilePath]) "frontend/dist/.manifest.yaml"
|
|
let
|
|
frontendContext = jsContext <> cssContext
|
|
where
|
|
cssContext = listField "css" innerContext genCSSItems
|
|
where
|
|
innerContext = urlField "url"
|
|
genCSSItems = genManifestItems $ Glob.compile "**/*.css"
|
|
jsContext = listField "js" innerContext genCSSItems
|
|
where
|
|
innerContext = urlField "url"
|
|
genCSSItems = genManifestItems $ Glob.compile "**/*.js"
|
|
|
|
genManifestItems :: Glob.Pattern -> Compiler [Item CopyFile]
|
|
genManifestItems p = do
|
|
let entryPoint = "main"
|
|
resources = filter (Glob.match p) $ frontendManifest Map.! entryPoint
|
|
forM resources $ load . fromFilePath . ("frontend/dist" </>) . dropDrive
|
|
|
|
netlifyRedirects <-
|
|
preprocess . handleIf isDoesNotExistError (const $ return []) $
|
|
let pNetlify :: ParsecT Void Lazy.Text m [(FilePath, FilePath)]
|
|
pNetlify = catMaybes <$> MP.sepBy (MP.space *> pLine <* MP.hspace) pEOL <* MP.eof
|
|
where
|
|
pEOL :: ParsecT Void Lazy.Text m ()
|
|
pEOL = void . MP.label "linebreak" $ MP.eol
|
|
pLine :: ParsecT Void Lazy.Text m (Maybe (FilePath, FilePath))
|
|
pLine = MP.label "line" $ (mempty <$ pComment) <|> pRedirect <|> pure Nothing
|
|
pComment :: ParsecT Void Lazy.Text m ()
|
|
pComment = void $ MP.char '#' *> MP.label "comment" (MP.manyTill MP.anySingle $ MP.lookAhead MP.eol)
|
|
pRedirect :: ParsecT Void Lazy.Text m (Maybe (FilePath, FilePath))
|
|
pRedirect = do
|
|
fromRoute <- MP.label "fromRoute" $ MP.manyTill MP.anySingle MP.separatorChar
|
|
MP.hspace
|
|
toRoute <- MP.label "toRoute" $ MP.manyTill MP.anySingle MP.separatorChar
|
|
MP.hspace
|
|
redirectMode <- MP.label "mode" $ asum [MP.string "200", MP.string "301", MP.string "302"]
|
|
return $
|
|
if
|
|
| redirectMode == "200" -> Just (fromRoute, toRoute)
|
|
| otherwise -> Nothing
|
|
in either throwIO return =<< MP.runParserT pNetlify "static/_redirects" =<< LT.readFile "static/_redirects"
|
|
let
|
|
renderRoute r
|
|
| fromRoute : _ <- mapMaybe (matchNetlifyRedirect r) netlifyRedirects =
|
|
fromRoute
|
|
| otherwise =
|
|
r
|
|
where
|
|
matchNetlifyRedirect :: FilePath -> (FilePath, FilePath) -> Maybe FilePath
|
|
matchNetlifyRedirect r' (fromRoute, toRoute) = do
|
|
tokens <- MP.parseMaybe pToSpec toRoute
|
|
Right subst <- return $ runReader (MP.runParserT (pRoute tokens <* MP.eof) "" r') Map.empty
|
|
return . T.unpack $ Map.foldrWithKey doSubst (T.pack fromRoute) subst
|
|
where
|
|
pToSpec :: Parsec Void FilePath [Either FilePath String]
|
|
pToSpec =
|
|
MP.some $
|
|
Left <$> MP.someTill (MP.anySingleBut ':') (MP.lookAhead $ MP.eof <|> void (MP.single ':'))
|
|
<|> Right <$> (MP.char ':' *> MP.some MP.letterChar)
|
|
pRoute :: [Either FilePath String] -> ParsecT Void FilePath (Reader (Map String String)) (Map String String)
|
|
pRoute [] = MP.eof *> ask
|
|
pRoute (t : ts) = case t of
|
|
Left str -> MP.string str *> pRoute ts
|
|
Right p -> do
|
|
pVal <- asks $ Map.lookup p
|
|
case pVal of
|
|
Nothing -> do
|
|
mLength <- length <$> MP.getInput
|
|
asum . flip map [0 .. mLength] $ \l -> MP.try $ do
|
|
val <- MP.takeP (Just $ ':' : p) l
|
|
newSubst <- asks $ Map.insert p val
|
|
newSubst <$ local (const newSubst) (pRoute ts)
|
|
Just pVal' -> MP.string pVal' *> ask
|
|
|
|
doSubst :: String -> String -> Text -> Text
|
|
doSubst k s = T.intercalate (T.pack s) . T.splitOn (T.pack $ ':' : k)
|
|
normalizeUrls :: Item String -> Compiler (Item String)
|
|
normalizeUrls item = do
|
|
itemRoute <- getRoute $ itemIdentifier item
|
|
let relativizeUrls' x = case itemRoute of
|
|
Just r
|
|
| "/" `List.isPrefixOf` x && not ("//" `List.isPrefixOf` x) ->
|
|
toSiteRoot r ++ x
|
|
_other -> x
|
|
return $ withUrls (relativizeUrls' . renderRoute) <$> item
|
|
|
|
tags <- buildTags "content/**" $ fromCapture "tags/*.html"
|
|
|
|
match "content/**" $ do
|
|
compile $ do
|
|
pandocCompiler
|
|
>>= normalizeUrls
|
|
|
|
forM_ (tagsMap tags) $ \(tag, fromList -> posts) ->
|
|
rulesExtraDependencies [tagsDependency tags] $ do
|
|
tagItems <- getMatches . fromGlob $ toFilePath (tagsMakeId tags tag) -<.> "*"
|
|
let tagItem = pandocCompiler <|> makeItem mempty
|
|
rule
|
|
| [] <- tagItems = create [tagsMakeId tags tag]
|
|
| otherwise = match (fromList tagItems)
|
|
|
|
rule $ do
|
|
route . routeAsFilePath $ (-<.> "html") . stripPathPrefix "tags"
|
|
compile $ do
|
|
let
|
|
ctx =
|
|
mconcat
|
|
[ listField "tags-nav" defaultContext (metadataSort <=< mapM (uncurry renderTagNav) $ tagsMap tags)
|
|
, listField "posts" postContext (metadataSort =<< loadAll posts)
|
|
, frontendContext
|
|
, defaultContext
|
|
]
|
|
|
|
renderTagNav tag' ids = do
|
|
tagItems' <- getMatches . fromGlob $ toFilePath (tagsMakeId tags tag') -<.> "*"
|
|
let
|
|
tagItem' = return $ Item (fromMaybe (tagsMakeId tags tag') $ listToMaybe tagItems') (mempty :: String)
|
|
|
|
navRoute = renderRoute $ "/" <> tag' <> ".html"
|
|
|
|
tagNavCtx =
|
|
mconcat
|
|
[ constField "tag" tag'
|
|
, field "title" . const $
|
|
fmap (fromMaybe tag') . runMaybeT . asum $
|
|
map (\itemId -> MaybeT $ getMetadataField itemId "title") tagItems'
|
|
, constField "route" navRoute
|
|
, listField "posts" (constField "tag" tag' <> constField "route" navRoute <> postContext) (metadataSort =<< mapM load ids)
|
|
]
|
|
tagItem'
|
|
>>= loadAndApplyTemplate "templates/tag-nav.html" tagNavCtx
|
|
>>= normalizeUrls
|
|
|
|
postContext =
|
|
mconcat
|
|
[ field "identifier" (return . takeBaseName . toFilePath . itemIdentifier)
|
|
, defaultContext
|
|
]
|
|
|
|
metadataSort :: [Item w] -> Compiler [Item w]
|
|
metadataSort = sortOnM $ \Item{itemIdentifier} -> maybe (0 :: Integer) read <$> getMetadataField itemIdentifier "sort"
|
|
where
|
|
sortOnM :: forall m a b. (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
|
|
sortOnM f = fmap (map snd . List.sortOn fst) . mapM (\x -> (,x) <$> f x)
|
|
|
|
tagItem
|
|
>>= loadAndApplyTemplate "templates/tag.html" ctx
|
|
>>= loadAndApplyTemplate "templates/site-layout.html" ctx
|
|
>>= normalizeUrls
|
|
|
|
match "frontend/dist/wp-*/**" $ do
|
|
route . routeAsFilePath $ stripPathPrefix "frontend/dist"
|
|
|
|
compile copyFileCompiler
|
|
|
|
match "templates/*" $ compile templateBodyCompiler
|
|
|
|
match "static/**" $ do
|
|
route . routeAsFilePath $ stripPathPrefix "static"
|
|
compile copyFileCompiler
|