gallery/make-pages/Main.hs

145 lines
4.5 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 qualified Data.List as List
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 (always, fileName, (==?))
import qualified System.FilePath.Find as File
import System.IO (hPrint, stderr)
import Depend
import Info hiding (Text)
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 {root, file, prefix, dataDir, nsfw, output}) = do
info <- readYAML file
printV $ "contents" := info
let dir = takeDirectory $ makeRelative dataDir file
page <- SinglePage.make root prefix nsfw dataDir dir info
writeOutput output page
main2 (GalleryPage {root, files, prefix, index, output, dataDir}) = do
ginfo <- galleryFromIndex index prefix
printV $ "gallery_info" := ginfo
infos <- mapM (infoYAML dataDir) files
printV $ "infos" := infos
let page = GalleryPage.make root ginfo infos
writeOutput output page
main2 (IndexPage {root, file, output}) = do
info <- readYAML file
printV $ "info" := info
let page = IndexPage.make root info
writeOutput output page
main2 (RSS {files, root, index, prefix, output, dataDir}) = do
ginfo <- galleryFromIndex index prefix
printV $ "gallery_info" := ginfo
infos <- mapM (infoYAML dataDir) files
printV $ "infos" := infos
let output' = takeFileName <$> output
let rss = RSS.make root ginfo 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 file infos buildDir dataDir tmpDir
let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $
map dependGallery0 galleries
writeOutput output deps
main2 (ListTags {nsfw, listUntagged, dataDir, infoName, sortBy}) = do
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
printV $ "info_files" := infos
ListTags.run nsfw listUntagged sortBy 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 =
File.findL True always (fileName ==? infoName) dataDir
readYAML :: YAML.FromYAML a => FilePath -> IO a
readYAML file = ByteString.readFile file >>= decode1Must file
galleryFromIndex :: FilePath -> FilePath -> IO GalleryInfo
galleryFromIndex file prefix = do
IndexInfo {galleries} <- readYAML file
maybe (fail $ "no gallery with prefix " ++ prefix) pure $
List.find (\g -> #prefix g == prefix) galleries
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