gallery/make-pages/Main.hs

131 lines
4 KiB
Haskell

{-# LANGUAGE CPP, ImplicitParams, TypeApplications #-}
module Main (main) where
import Control.Monad
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString
import Data.List (intersperse)
import Data.Text.Lazy (Text)
import Data.Text.Lazy.Builder (toLazyText)
import qualified Data.Text.Lazy.IO as Text
import qualified Data.YAML as YAML
import System.FilePath (makeRelative, takeDirectory, takeFileName)
import System.FilePath.Find (find, always, fileName, (==?))
import System.IO (hPrint, stderr)
import Depend
import Info (IndexInfo (..), Info)
import Options
import qualified SinglePage
import qualified GalleryPage
import qualified IndexPage
import qualified RSS
import qualified ListTags
#ifdef PRETTY_VERBOSE
import qualified Text.PrettyPrint as PP
import qualified Text.Show.Pretty as PP
#endif
type HasVerbose = (?verbose :: Bool)
withVerbose :: Bool -> (HasVerbose => a) -> a
withVerbose v x = let ?verbose = v in x
printV :: (Show a, HasVerbose) => a -> IO ()
printV x = when ?verbose $ hPrint stderr x
main :: IO ()
main = do
opts@(Options {verbose, mode}) <- parseOptions
withVerbose verbose do
printV $ "options" := opts
main2 mode
main2 :: HasVerbose => ModeOptions -> IO ()
main2 (SinglePage {file, dataDir, nsfw, output}) = do
info <- readYAML file
printV $ "contents" := info
let dir = takeDirectory $ makeRelative dataDir file
let page = SinglePage.make nsfw dir info
writeOutput output page
main2 (GalleryPage {title, prefix, files, nsfw, output, dataDir}) = do
infos <- mapM (infoYAML dataDir) files
printV $ "infos" := infos
let page = GalleryPage.make title prefix nsfw infos
writeOutput output page
main2 (IndexPage {file, output}) = do
info <- readYAML file
printV $ "info" := info
let page = IndexPage.make info
writeOutput output page
main2 (RSS {files, title, desc, root, prefix, output, dataDir}) = do
infos <- mapM (infoYAML dataDir) files
printV $ "infos" := infos
let output' = takeFileName <$> output
let rss = RSS.make root title desc prefix output' infos
writeOutput output rss
main2 (DependSingle {file, nsfw, output, prefix, buildDir, dataDir}) = do
info <- readYAML file
printV $ "contents" := info
let dir = takeDirectory $ makeRelative dataDir file
printV $ "dir" := dir
let deps = dependSingle dir info prefix buildDir nsfw
writeOutput output deps
main2 (DependGallery {file, output, buildDir, dataDir, tmpDir, infoName}) = do
IndexInfo {galleries} <- readYAML file
printV $ "galleries" := galleries
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
printV $ "info files" := infos
let dependGallery0 g = dependGallery' g infos buildDir dataDir tmpDir
let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $
map dependGallery0 galleries
writeOutput output deps
main2 (ListTags {nsfw, listUntagged, dataDir, infoName}) = do
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
ListTags.run nsfw listUntagged infos
infoYAML :: FilePath -- ^ data dir
-> FilePath -- ^ yaml file
-> IO (FilePath, Info) -- relative filename, contents
infoYAML dataDir f = do
let f' = makeRelative dataDir f
info <- readYAML f
pure (f', info)
findInfos :: FilePath -> FilePath -> IO [FilePath]
findInfos dataDir infoName = find always (fileName ==? infoName) dataDir
readYAML :: YAML.FromYAML a => FilePath -> IO a
readYAML file = ByteString.readFile file >>= decode1Must file
decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a
decode1Must file txt =
case YAML.decode1 txt of
Right val -> pure val
Left (pos, err) ->
fail $ file ++ ":" ++ YAML.prettyPosWithSource pos txt " error:" ++ err
writeOutput :: Maybe FilePath -> Text -> IO ()
writeOutput (Just f) = Text.writeFile f
writeOutput Nothing = Text.putStrLn
data Tag a = String := a
instance Show a => Show (Tag a) where
show (tag := a) =
#ifdef PRETTY_VERBOSE
PP.render $ PP.hang (PP.text tag <> ":") 2 (PP.ppDoc a)
#else
tag ++ ": " ++ show a
#endif