From 924746b8ab4904d24a3cb242b95e8b91f0970129 Mon Sep 17 00:00:00 2001 From: Thomas Ulmer Date: Tue, 2 Jun 2026 17:19:14 -0700 Subject: initial (functional?) version --- src/Main.hs | 257 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 257 insertions(+) create mode 100644 src/Main.hs (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..6d116a0 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,257 @@ +module Main where + +import System.Directory +import System.FilePath +import System.Environment (getArgs) +import System.IO +import Data.Maybe (fromMaybe, isJust, fromJust) +import Data.List (isPrefixOf, isSuffixOf, scanl, scanr, zipWith3, intersperse, sort, inits, tails) +import Control.Monad (when, unless) +import System.Exit (die) + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +isFragment :: FilePath -> Bool +isFragment f = + (isSuffixOf ".html" f || isSuffixOf ".frag" f) + +valid :: FilePath -> FilePath -> Bool +valid r f = + and $ (isAbsolute r):(isAbsolute f):zipWith (==) r f + +prettyName :: FilePath -> String +{- XXX more -} +prettyName f = takeBaseName $ dropExtension f + +header :: T.Text -> T.Text -> T.Text +header title nav = T.unlines + [ T.pack "" + , T.pack "" + , T.pack " " + , T.pack " " + , T.concat [T.pack " " , title , T.pack "" ] + , T.pack " " + , T.pack " " + , T.pack " " + , T.pack " " + , T.pack "
" + , T.pack "
" + , T.pack "

" + , T.pack " Professional Webring >>" + , T.pack " Prev - Roscoe" + , T.pack " |" + , T.pack " Next - Elle" + , T.pack "

" + , T.pack "
" + , T.concat [ T.pack "" ] + , T.pack "
" + , T.pack "
" + ] + +footer :: T.Text +footer = T.pack $ unlines + [ "
" + , "" + , "" + , "" + ] + +parse :: FilePath -> IO (T.Text, T.Text) +{- XXX use T.hGetLine to try to delay the memory cost. + +Maybe doesn't matter if I'm going to have it all in memory later +anyway? +-} +parse f = withFile f ReadMode $ \h -> do + c <- T.hGetContents h + case T.lines c of + [] -> pure (fallback, c) + l:_ -> case T.stripPrefix (T.pack "") of + Nothing -> pure (fallback, c) + Just comment -> + let pairs = T.splitOn (T.pack "|") comment + kvs = map (dropEq . T.span (/= '=')) pairs + name = fromMaybe fallback $ lookup (T.pack "title") kvs + in pure (name, c) + where fallback = T.pack $ prettyName f + dropEq (key, ev) = case T.uncons ev of + Just ('=', rest) -> (key,rest) + _ -> (key, ev) + +data Nav + = NavDir { navChildren :: [Nav] + , navIndexFrag :: Nav {- will be NavFile, contains title -} + , navDirPath :: FilePath + } + | NavFile { navFrag :: T.Text + , navTitle :: T.Text + , navFilePath :: FilePath + } + +instance Show Nav where + show (NavDir cs _ p) = + concat $ intersperse "\n" + [ "NavDir " ++ p ++ ":" + , concat $ intersperse "\n" $ map (indent . show) cs + ] + where indent s = concat $ intersperse "\n" $ map ("\t"++) $ lines s + show (NavFile _ t p) = + "NavFile " ++ T.unpack t ++ " " ++ p + +convert :: FilePath -> FilePath -> IO Nav +convert r f = do + unless (valid r f) $ + error $ "Don't know what to do with: " ++ f + de <- doesDirectoryExist f + fe <- (isFragment f &&) <$> doesFileExist f + case de of + True -> do + allChildren <- (map (f )) <$> listDirectory f + let downlinks = sort $ filter (\x -> valid r x && not (isSuffixOf "index.html" x)) $ allChildren + navChildren <- mapM (convert r) downlinks + navIndexFrag <- do + let ifp = f "index.html" + fe <- doesFileExist ifp + case fe of + True -> do + (name, contents) <- parse ifp + pure $ NavFile contents name (makeRelative r ifp) + False -> pure $ fallbackIndexNav (makeRelative r ifp) navChildren + let navDirPath = makeRelative r f + pure $ NavDir { navChildren = navChildren + , navIndexFrag = navIndexFrag + , navDirPath = navDirPath + } + False -> case fe of + True -> do + (navTitle, navFrag) <- parse f + let navFilePath = makeRelative r f + pure $ NavFile { navFrag = navFrag + , navTitle = navTitle + , navFilePath = navFilePath + } + False -> + error $ "Path doesn't exist or is not a directory or file: " ++ f + +fallbackIndexNav :: FilePath -> [Nav] -> Nav +fallbackIndexNav p ns = NavFile (fallbackIndexFrag p ns) (T.pack . takeFileName $ takeDirectory p) p + +fallbackIndexFrag :: FilePath -> [Nav] -> T.Text +fallbackIndexFrag _ _ = (T.pack "

Fallback index.

") + +generate :: T.Text -> Nav -> T.Text +{- Generate the full text of a page. -} +generate nav (NavFile f t _) = + T.concat [ header t nav , f , footer ] +generate nav (NavDir _ (NavFile f t _) _) = + T.concat [ header t nav , f , footer ] +generate _ _ = error "malformed NavDir" + +mkNavItem :: Nav -> T.Text +{- Generate a listing for a file or a listing for a dir and optionally + one level of children -} +mkNavItem (NavFile _ t p) = + T.concat [ T.pack "
  • "html") + , T.pack "\">" + , t + , T.pack "
    • " + ] +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 + T.writeFile (outdir p -<.> "html") contents +emit outdir nav1 (NavDir cs i dp) nav2 = do + let newdir = outdir dp + exists <- doesDirectoryExist newdir + unless exists $ createDirectory newdir + + let sharedBefore = T.append nav1 $ T.pack "
  • ") nav2 + let ncs = map mkNavItem cs + let priors = inits ncs + 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) + _ <- sequence actions + emit outdir (head nbefore) i (head nafter) + +main :: IO () +main = do + flags@(Flags r o s) <- canonicalizeFlags <$> handleArgs + unless (valid r r) $ + die $ "R isn't valid. Maybe not absolute? " ++ r + unless (isAbsolute o) $ + die $ "O not absolute " ++ o + hPutStr stderr $ "Using config: " ++ show flags + tree <- convert r r + hPutStr stderr $ "\nFound tree:\n" ++ show tree + let rNav = T.append (mkNavItem tree) (T.pack "") + 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) + +data Flags = Flags + { root :: FilePath + , output :: FilePath + , static :: Maybe FilePath + } + deriving (Show) + +handleArgs :: IO Flags +handleArgs = do + args <- getArgs + when (null args) $ die usage + let missing = Flags + { root = error "-r root is required" + , output = error "-o output 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 ("-s":a:rest) = helper (f { static = Just a }) rest + helper _ ("-h":_) = die usage + helper _ (x:_) = die $ "Unknown or orphan flag: " ++ x ++ "\n" ++ usage + +usage :: String +usage = unlines + [ "Usage:" + , "\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-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:" + , "\t" + , "note that the spaces are important. The title may not contain newlines or the vertical bar character." + ] + +copyInto :: FilePath -> FilePath -> IO () +copyInto src dst = do + se <- doesDirectoryExist src + unless se $ + die $ "source does not exist: " ++ src + de <- doesDirectoryExist dst + unless de $ createDirectory dst + when (isPrefixOf src dst) $ + die $ "Overlapping directories: " ++ src ++ " to " ++ dst + content <- listDirectory src + flip mapM_ content $ \name -> do + let srcPath = src name + let dstPath = dst name + isDirectory <- doesDirectoryExist srcPath + if isDirectory + then copyInto srcPath dstPath + else copyFile srcPath dstPath -- cgit v1.2.3