132 lines
4 KiB
Haskell
132 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
|
|
printV $ "info files" := infos
|
|
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
|