diff --git a/src/Main.hs b/src/Main.hs index 5675cb4..0dc75de 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -39,6 +39,8 @@ import Data.Void import Network.URI +import System.Environment (lookupEnv) + config :: Configuration config = defaultConfiguration @@ -65,180 +67,184 @@ unwrapped :: Snapshot unwrapped = "unwrapped" 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 +main = + lookupEnv "LOCALHOST" >>= \((Nothing /=) -> localhost) -> 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 - 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 + innerContext = urlField "url" + genCSSItems = genManifestItems $ Glob.compile "**/*.css" + jsContext = listField "js" innerContext genCSSItems + where + innerContext = urlField "url" + genCSSItems = genManifestItems $ Glob.compile "**/*.js" - 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 - overPath f str = case parseURIReference str of - Nothing -> f str - Just uri@URI{uriPath} -> uriToString id uri{uriPath = f uriPath} mempty - return $ withUrls (relativizeUrls' . overPath renderRoute) <$> item + 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 - tags <- buildTags "content/**" $ fromCapture "tags/*.html" + netlifyRedirects <- + if localhost + then return [] + else + 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 - let - applySiteLayout = loadAndApplyTemplate "templates/site-layout.html" . (<> ctx') - where - ctx' = - mconcat - [ listField "tags-nav" defaultContext (metadataSort <=< mapM (uncurry renderTagNav) $ tagsMap tags) - , listField "special-nav" defaultContext $ metadataSort =<< mapM (flip loadSnapshot unwrapped) =<< getMatches (fromGlob "special/**") - , 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) + 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 + overPath f str = case parseURIReference str of + Nothing -> f str + Just uri@URI{uriPath} -> uriToString id uri{uriPath = f uriPath} mempty + return $ withUrls (relativizeUrls' . overPath renderRoute) <$> item - navRoute = "/" <> tag' <> ".html" + tags <- buildTags "content/**" $ fromCapture "tags/*.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 - ] - specialContext = defaultContext + let + applySiteLayout = loadAndApplyTemplate "templates/site-layout.html" . (<> ctx') + where + ctx' = + mconcat + [ listField "tags-nav" defaultContext (metadataSort <=< mapM (uncurry renderTagNav) $ tagsMap tags) + , listField "special-nav" defaultContext $ metadataSort =<< mapM (flip loadSnapshot unwrapped) =<< getMatches (fromGlob "special/**") + , 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) - match "content/**" $ do - compile $ - pandocCompiler - >>= normalizeUrls + navRoute = "/" <> tag' <> ".html" - match "special/**" $ do - route . routeAsFilePath $ (-<.> "html") . stripPathPrefix "special" - compile $ - pandocCompiler - >>= saveSnapshot unwrapped - >>= applySiteLayout specialContext - >>= normalizeUrls + 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 + ] + specialContext = defaultContext - 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) + match "content/**" $ do + compile $ + pandocCompiler + >>= normalizeUrls - rule $ do - route . routeAsFilePath $ (-<.> "html") . stripPathPrefix "tags" - compile $ do - let - ctx = - mconcat - [ listField "posts" postContext (metadataSort =<< loadAll posts) - , defaultContext - ] + match "special/**" $ do + route . routeAsFilePath $ (-<.> "html") . stripPathPrefix "special" + compile $ + pandocCompiler + >>= saveSnapshot unwrapped + >>= applySiteLayout specialContext + >>= normalizeUrls - tagItem - >>= loadAndApplyTemplate "templates/tag.html" ctx - >>= applySiteLayout ctx - >>= 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) - match "frontend/dist/wp-*/**" $ do - route . routeAsFilePath $ stripPathPrefix "frontend/dist" + rule $ do + route . routeAsFilePath $ (-<.> "html") . stripPathPrefix "tags" + compile $ do + let + ctx = + mconcat + [ listField "posts" postContext (metadataSort =<< loadAll posts) + , defaultContext + ] - compile copyFileCompiler + tagItem + >>= loadAndApplyTemplate "templates/tag.html" ctx + >>= applySiteLayout ctx + >>= normalizeUrls - match "templates/*" $ compile templateBodyCompiler + match "frontend/dist/wp-*/**" $ do + route . routeAsFilePath $ stripPathPrefix "frontend/dist" - match "static/**" $ do - route . routeAsFilePath $ stripPathPrefix "static" - compile copyFileCompiler + compile copyFileCompiler + + match "templates/*" $ compile templateBodyCompiler + + match "static/**" $ do + route . routeAsFilePath $ stripPathPrefix "static" + compile copyFileCompiler