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 Data.Foldable (foldrM) 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) $ die $ "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 $ allChildren let filterInterested c acc = do isDir <- doesDirectoryExist c case isDir || ((isFragment c) && (not $ isSuffixOf "index.html" c)) of True -> pure $ c:acc False -> pure acc filtered <- foldrM filterInterested [] downlinks navChildren <- mapM (convert r) filtered 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 -> die $ "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 (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