path: root/src/Main.hs

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

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 "<!-- == ") l
                >>= T.stripSuffix (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 "<p>Fallback index.</p>")

generate :: (T.Text -> T.Text -> T.Text, T.Text) -> T.Text -> Nav -> T.Text
{- Generate the full text of a page. -}
generate (header, footer) nav (NavFile f t _) =
  T.concat [ header t nav , f , footer ]
generate (header, footer) 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 "<li><a class='active' href=\""
           , T.pack $ (pathSeparator:p -<.> "html")
           , T.pack "\">"
           , t
           , T.pack "</a></li>"
           ]
mkNavItem (NavDir _ idxf _) = mkNavItem idxf

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 hf 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 "<ul>"
  let sharedAfter = T.append (T.pack "</ul>") 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 hf outdir) (tail nbefore) cs (tail nafter)
  _ <- sequence actions
  emit hf outdir (head nbefore) i (head nafter)

main :: IO ()
main = do
  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) $
    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 "<ul>") (mkNavItem tree)
  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 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)

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"
        , 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

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-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:"
  , "\t<!-- == title={title} -->"
  , "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