diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4d5d56e..94c279d 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -20,7 +20,7 @@ stages: pages: stage: deploy - script: &build-script + script: - nix develop -c gup public artifacts: paths: @@ -30,7 +30,9 @@ pages: review:start: stage: review - script: *build-script + script: + - rm -fv static/_redirects + - nix develop -c gup public artifacts: paths: - public diff --git a/package.yaml b/package.yaml index 79abdd2..fea9dff 100644 --- a/package.yaml +++ b/package.yaml @@ -33,3 +33,6 @@ executables: - containers - Glob - transformers + - mtl + - megaparsec + - text diff --git a/src/Main.hs b/src/Main.hs index 8c6590d..0c2c163 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,6 +4,7 @@ import Prelude import Hakyll +import Data.Bool import Data.List qualified as List import Data.Maybe @@ -16,10 +17,26 @@ 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 @@ -33,6 +50,9 @@ 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 <- @@ -56,12 +76,80 @@ main = hakyllWith config $ do 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 - >>= relativizeUrls + >>= normalizeUrls forM_ (tagsMap tags) $ \(tag, fromList -> posts) -> rulesExtraDependencies [tagsDependency tags] $ do @@ -88,9 +176,7 @@ main = hakyllWith config $ do let tagItem' = return $ Item (fromMaybe (tagsMakeId tags tag') $ listToMaybe tagItems') (mempty :: String) - navRoute - | tag' == "index" = "/" - | otherwise = "/" <> tag' <> ".html" + navRoute = renderRoute $ "/" <> tag' <> ".html" tagNavCtx = mconcat @@ -103,7 +189,7 @@ main = hakyllWith config $ do ] tagItem' >>= loadAndApplyTemplate "templates/tag-nav.html" tagNavCtx - >>= relativizeUrls + >>= normalizeUrls postContext = mconcat @@ -120,7 +206,7 @@ main = hakyllWith config $ do tagItem >>= loadAndApplyTemplate "templates/tag.html" ctx >>= loadAndApplyTemplate "templates/site-layout.html" ctx - >>= relativizeUrls + >>= normalizeUrls match "frontend/dist/wp-*/**" $ do route . routeAsFilePath $ stripPathPrefix "frontend/dist" diff --git a/static/_redirects b/static/_redirects index 5d87c4e..aed8659 100644 --- a/static/_redirects +++ b/static/_redirects @@ -1 +1,3 @@ / /index.html 200 + +/:tag /:tag.html 200