gallery/make-pages/Main.hs

{-# 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