normalize links automagically by parsing _redirects

Fixes #2

.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

package.yaml

@@ -33,3 +33,6 @@ executables:
       - containers
       - Glob
       - transformers
+      - mtl
+      - megaparsec
+      - text

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
+                navRoute = renderRoute $ "/" <> tag' <> ".html"
-                  | tag' == "index" = "/"
-                  | otherwise = "/" <> 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"

static/_redirects

@@ -1 +1,3 @@
 / /index.html 200
+
+/:tag /:tag.html 200