gallery/make-pages/Main.hs

147 lines
4.6 KiB
Haskell
Raw Normal View History

2020-07-16 10:07:28 -04:00
{-# LANGUAGE CPP, ImplicitParams, TypeApplications #-}
2020-07-07 18:21:08 -04:00
module Main (main) where
2020-07-16 10:07:28 -04:00
import Control.Monad
2020-07-12 23:01:57 -04:00
import Data.ByteString.Lazy (ByteString)
2020-07-16 10:07:28 -04:00
import qualified Data.ByteString.Lazy as ByteString
import Data.List (intersperse)
import qualified Data.List as List
import Data.Text.Lazy (Text)
2020-07-16 10:07:28 -04:00
import Data.Text.Lazy.Builder (toLazyText)
import qualified Data.Text.Lazy.IO as Text
2020-07-16 10:07:28 -04:00
import qualified Data.YAML as YAML
2020-07-19 12:04:40 -04:00
import System.FilePath (makeRelative, takeDirectory, takeFileName)
import System.FilePath.Find (always, fileName, (==?))
import qualified System.FilePath.Find as File
2020-07-15 06:07:04 -04:00
import System.IO (hPrint, stderr)
2020-07-15 14:06:19 -04:00
import Depend
import Info hiding (Text)
2020-07-16 10:07:28 -04:00
import Options
import qualified SinglePage
import qualified GalleryPage
2020-07-16 10:29:32 -04:00
import qualified IndexPage
2020-07-19 12:04:40 -04:00
import qualified RSS
2020-07-25 09:05:38 -04:00
import qualified ListTags
2020-07-09 00:20:57 -04:00
2020-07-15 05:43:57 -04:00
#ifdef PRETTY_VERBOSE
2020-07-15 06:07:04 -04:00
import qualified Text.PrettyPrint as PP
2020-07-16 10:07:28 -04:00
import qualified Text.Show.Pretty as PP
2020-07-15 05:43:57 -04:00
#endif
2020-07-09 00:20:57 -04:00
2020-07-15 14:06:19 -04:00
type HasVerbose = (?verbose :: Bool)
2020-07-16 05:47:34 -04:00
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
2020-07-07 18:21:08 -04:00
main :: IO ()
2020-07-12 23:01:57 -04:00
main = do
2020-07-15 14:06:19 -04:00
opts@(Options {verbose, mode}) <- parseOptions
2020-07-16 05:47:34 -04:00
withVerbose verbose do
printV $ "options" := opts
main2 mode
2020-07-09 00:20:57 -04:00
2020-07-15 14:06:19 -04:00
main2 :: HasVerbose => ModeOptions -> IO ()
main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do
siteName <- #title <$> readYAML @IndexInfo index
2020-07-12 23:01:57 -04:00
info <- readYAML file
2020-07-16 05:47:34 -04:00
printV $ "contents" := info
2020-07-21 18:13:02 -04:00
let dir = takeDirectory $ makeRelative dataDir file
page <- SinglePage.make root siteName prefix nsfw dataDir dir info
writeOutput output page
2020-08-11 14:29:54 -04:00
main2 (GalleryPage {root, files, prefix, index, output, dataDir}) = do
ginfo <- galleryFromIndex index prefix
printV $ "gallery_info" := ginfo
2020-07-16 10:07:28 -04:00
infos <- mapM (infoYAML dataDir) files
printV $ "infos" := infos
2020-08-11 14:29:54 -04:00
let page = GalleryPage.make root ginfo infos
2020-07-16 10:07:28 -04:00
writeOutput output page
2020-08-11 14:29:54 -04:00
main2 (IndexPage {root, file, output}) = do
2020-07-18 05:45:32 -04:00
info <- readYAML file
printV $ "info" := info
2020-08-11 14:29:54 -04:00
let page = IndexPage.make root info
2020-07-16 10:29:32 -04:00
writeOutput output page
main2 (RSS {files, root, index, prefix, output, dataDir}) = do
ginfo <- galleryFromIndex index prefix
printV $ "gallery_info" := ginfo
2020-07-19 12:04:40 -04:00
infos <- mapM (infoYAML dataDir) files
printV $ "infos" := infos
let output' = takeFileName <$> output
let rss = RSS.make root ginfo output' infos
2020-07-19 12:04:40 -04:00
writeOutput output rss
main2 (DependSingle {index, file, nsfw, output, prefix, buildDir, dataDir}) = do
info <- readYAML file
2020-07-16 05:47:34 -04:00
printV $ "contents" := info
2020-07-16 10:07:28 -04:00
let dir = takeDirectory $ makeRelative dataDir file
printV $ "dir" := dir
let deps = dependSingle dir index info prefix buildDir nsfw
2020-07-16 10:07:28 -04:00
writeOutput output deps
main2 (DependGallery {file, output, buildDir, dataDir, tmpDir, infoName}) = do
2020-07-18 05:45:32 -04:00
IndexInfo {galleries} <- readYAML file
printV $ "galleries" := galleries
2020-07-25 09:05:38 -04:00
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
printV $ "info_files" := infos
let dependGallery0 g = dependGallery' g file infos buildDir dataDir tmpDir
2020-07-16 10:07:28 -04:00
let deps = toLazyText $ mconcat $ intersperse "\n\n\n" $
2020-07-18 05:45:32 -04:00
map dependGallery0 galleries
writeOutput output deps
2021-03-07 14:51:44 -05:00
main2 (ListTags {nsfw, listUntagged, dataDir, infoName, sortBy}) = do
2020-07-25 09:05:38 -04:00
infos <- mapM (infoYAML dataDir) =<< findInfos dataDir infoName
printV $ "info_files" := infos
2021-03-07 14:51:44 -05:00
ListTags.run nsfw listUntagged sortBy infos
2020-07-25 09:05:38 -04:00
2020-07-16 10:07:28 -04:00
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)
2020-07-15 05:43:57 -04:00
2020-07-25 09:05:38 -04:00
findInfos :: FilePath -> FilePath -> IO [FilePath]
2021-04-16 15:34:48 -04:00
findInfos dataDir infoName =
File.findL True always (fileName ==? infoName) dataDir
2020-07-12 23:01:57 -04:00
readYAML :: YAML.FromYAML a => FilePath -> IO a
2020-07-12 23:01:57 -04:00
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
2020-07-12 23:01:57 -04:00
decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a
decode1Must file txt =
case YAML.decode1 txt of
Right val -> pure val
2020-07-16 05:47:34 -04:00
Left (pos, err) ->
fail $ file ++ ":" ++ YAML.prettyPosWithSource pos txt " error:" ++ err
2020-07-15 05:43:57 -04:00
writeOutput :: Maybe FilePath -> Text -> IO ()
writeOutput (Just f) = Text.writeFile f
writeOutput Nothing = Text.putStrLn
2020-07-16 05:47:34 -04:00
data Tag a = String := a
2020-07-15 06:07:04 -04:00
instance Show a => Show (Tag a) where
2020-07-16 05:47:34 -04:00
show (tag := a) =
2020-07-15 06:07:04 -04:00
#ifdef PRETTY_VERBOSE
PP.render $ PP.hang (PP.text tag <> ":") 2 (PP.ppDoc a)
#else
tag ++ ": " ++ show a
#endif