diff options
| author | Thomas Ulmer <thomasmulmer02@gmail.com> | 2026-06-03 16:36:21 -0700 |
|---|---|---|
| committer | Thomas Ulmer <thomasmulmer02@gmail.com> | 2026-06-03 16:36:21 -0700 |
| commit | b4c02352143c05fdbe35629bed63f6ad32cbd313 (patch) | |
| tree | 47b321624625ab348b218377d84a91f27f98c7d5 /src | |
| parent | 1ed4e153285f84b97ac959b3c353049a6dcf0e33 (diff) | |
Diffstat (limited to 'src')
| -rw-r--r-- | src/Main.hs | 74 |
1 files changed, 26 insertions, 48 deletions
diff --git a/src/Main.hs b/src/Main.hs index 2e80a6a..3499403 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,40 +25,6 @@ prettyName :: FilePath -> String {- XXX more -} prettyName f = takeBaseName $ dropExtension f -header :: T.Text -> T.Text -> T.Text -header title nav = T.unlines - [ T.pack "<!DOCTYPE html>" - , T.pack "<html>" - , T.pack " <head>" - , T.pack " <meta charset='UTF-8' />" - , T.concat [T.pack " <title>" , title , T.pack "</title>" ] - , T.pack " <link rel=\"stylesheet\" href=\"/css/style.css\" />" - , T.pack " <link rel=\"icon\" href=\"/favicon.ico\" type=\"image/x-icon\"/>" - , T.pack " </head>" - , T.pack " <body>" - , T.pack " <div class=\"stuck\">" - , T.pack " <header>" - , T.pack " <p>" - , T.pack " Professional Webring >>" - , T.pack " <a href=\"https://roscoeeh.github.io\">Prev - Roscoe</a>" - , T.pack " |" - , T.pack " <a href=\"https://elle-wen.github.io\">Next - Elle</a>" - , T.pack " </p>" - , T.pack " </header>" - , T.concat [ T.pack "<nav>" , nav , T.pack "</nav>" ] - , T.pack " </div>" - , T.pack " <main>" - ] - -footer :: T.Text -footer = T.pack $ unlines - [ "</main>" - , "<footer>" - , "</footer>" - , "</body>" - , "</html>" - ] - parse :: FilePath -> IO (T.Text, T.Text) {- XXX use T.hGetLine to try to delay the memory cost. @@ -149,13 +115,13 @@ fallbackIndexNav p ns = NavFile (fallbackIndexFrag p ns) (T.pack . takeFileName fallbackIndexFrag :: FilePath -> [Nav] -> T.Text fallbackIndexFrag _ _ = (T.pack "<p>Fallback index.</p>") -generate :: T.Text -> Nav -> T.Text +generate :: (T.Text -> T.Text -> T.Text, T.Text) -> T.Text -> Nav -> T.Text {- Generate the full text of a page. -} -generate nav (NavFile f t _) = +generate (header, footer) nav (NavFile f t _) = T.concat [ header t nav , f , footer ] -generate nav (NavDir _ (NavFile f t _) _) = +generate (header, footer) nav (NavDir _ (NavFile f t _) _) = T.concat [ header t nav , f , footer ] -generate _ _ = error "malformed NavDir" +generate _ _ _ = error "malformed NavDir" mkNavItem :: Nav -> T.Text {- Generate a listing for a file or a listing for a dir and optionally @@ -169,11 +135,11 @@ mkNavItem (NavFile _ t p) = ] mkNavItem (NavDir _ idxf _) = mkNavItem idxf -emit :: FilePath -> T.Text -> Nav -> T.Text -> IO () -emit outdir nav1 f@(NavFile _ _ p) nav2 = do - let contents = generate (T.append nav1 nav2) f +emit :: (T.Text -> T.Text -> T.Text, T.Text) -> FilePath -> T.Text -> Nav -> T.Text -> IO () +emit hf outdir nav1 f@(NavFile _ _ p) nav2 = do + let contents = generate hf (T.append nav1 nav2) f T.writeFile (outdir </> p -<.> "html") contents -emit outdir nav1 (NavDir cs i dp) nav2 = do +emit hf outdir nav1 (NavDir cs i dp) nav2 = do let newdir = outdir </> dp exists <- doesDirectoryExist newdir unless exists $ createDirectory newdir @@ -185,13 +151,13 @@ emit outdir nav1 (NavDir cs i dp) nav2 = do let posts = tails ncs let nbefore = map (\x -> T.append sharedBefore (T.concat x)) priors let nafter = map (\x -> T.append (T.concat x) sharedAfter ) posts - let actions = zipWith3 (emit outdir) (tail nbefore) cs (tail nafter) + let actions = zipWith3 (emit hf outdir) (tail nbefore) cs (tail nafter) _ <- sequence actions - emit outdir (head nbefore) i (head nafter) + emit hf outdir (head nbefore) i (head nafter) main :: IO () main = do - flags@(Flags r o s) <- canonicalizeFlags <$> handleArgs + flags@(Flags r o h f s) <- canonicalizeFlags <$> handleArgs unless (valid r r) $ die $ "R isn't valid. Maybe not absolute? " ++ r unless (isAbsolute o) $ @@ -200,17 +166,22 @@ main = do tree <- convert r r hPutStr stderr $ "\nFound tree:\n" ++ show tree let rNav = T.append (T.pack "<ul>") (mkNavItem tree) - emit o rNav tree (T.pack "</ul>") + headerTemplate <- withFile h ReadMode T.hGetContents + let headerFunc title nav = T.replace (T.pack "%t") title $ T.replace (T.pack "%n") nav headerTemplate + footer <- withFile f ReadMode T.hGetContents + emit (headerFunc,footer) o rNav tree (T.pack "</ul>") when (isJust s) $ case isAbsolute $ fromJust s of True -> copyInto (fromJust s) o False -> die $ "S input not absolute " ++ (fromJust s) - where canonicalizeFlags (Flags r o s) = - Flags (normalise r) (normalise o) (normalise <$> s) + where canonicalizeFlags (Flags r o h f s) = + Flags (normalise r) (normalise o) (normalise h) (normalise f) (normalise <$> s) data Flags = Flags { root :: FilePath , output :: FilePath + , header :: FilePath + , footer :: FilePath , static :: Maybe FilePath } deriving (Show) @@ -222,12 +193,16 @@ handleArgs = do let missing = Flags { root = error "-r root is required" , output = error "-o output is required" + , header = error "-e header.html is required" + , footer = error "-f footer.html is required" , static = Nothing } helper missing args where helper f [] = pure f helper f ("-r":a:rest) = helper (f { root = a }) rest helper f ("-o":a:rest) = helper (f { output = a }) rest + helper f ("-e":a:rest) = helper (f { header = a }) rest + helper f ("-f":a:rest) = helper (f { footer = a }) rest helper f ("-s":a:rest) = helper (f { static = Just a }) rest helper _ ("-h":_) = die usage helper _ (x:_) = die $ "Unknown or orphan flag: " ++ x ++ "\n" ++ usage @@ -238,6 +213,9 @@ usage = unlines , "\tloom -r {root path} -o {output path} [-s {static path}]" , "\t-r supplies a root to pull fragments from" , "\t-o supplies the output directory to place html in" + , "\t-e supplies a html template for the header of each page" + , "\t\t%t is replaced with the title, and %n with the nav contents." + , "\t-f supplies a html template for the footer. " , "\t-s (optional) supplies a directory to be copied into the output after generation" , "all paths must be absolute." , "any fragment may be given a name by having the first line be in the following format:" |