parent
014952290e
commit
af64b14797
@ -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
|
||||
|
||||
@ -33,3 +33,6 @@ executables:
|
||||
- containers
|
||||
- Glob
|
||||
- transformers
|
||||
- mtl
|
||||
- megaparsec
|
||||
- text
|
||||
|
||||
98
src/Main.hs
98
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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user