normalize links automagically by parsing _redirects

Fixes #2
2023-05-15 15:02:01 +02:00 · 2023-05-15 15:02:01 +02:00 · c91de20ef1
commit c91de20ef1
parent 014952290e
4 changed files with 101 additions and 8 deletions
--- 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
--- a/package.yaml
+++ b/package.yaml
@ -33,3 +33,6 @@ executables:
      - containers
      - Glob
      - transformers
+      - mtl
+      - megaparsec
+      - text
--- 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"
--- a/static/_redirects
+++ b/static/_redirects
@ -1 +1,3 @@
 / /index.html 200
+
+/:tag /:tag.html 200