{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}

module Ema.Generate (
  generateSiteFromModel,
  generateSiteFromModel',
) where

import Control.Exception (throwIO)
import Control.Monad.Except (MonadError (throwError))
import Control.Monad.Logger (
  LogLevel (LevelError, LevelInfo),
  MonadLogger,
  MonadLoggerIO,
  logWithoutLoc,
 )
import Ema.Asset (Asset (..))
import Ema.CLI (crash)
import Ema.Route.Class (IsRoute (RouteModel, routePrism, routeUniverse))
import Ema.Route.Prism (
  checkRoutePrismGivenRoute,
  fromPrism_,
 )
import Ema.Site (EmaSite (siteOutput), EmaStaticSite)
import Optics.Core (review)
import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist)
import System.FilePath (takeDirectory, (</>))
import System.FilePattern.Directory (getDirectoryFiles)

log :: MonadLogger m => LogLevel -> Text -> m ()
log :: forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log = forall (m :: Type -> Type) msg.
(MonadLogger m, ToLogStr msg) =>
Text -> LogLevel -> msg -> m ()
logWithoutLoc Text
"ema.generate"

{- | Generate the static site at `dest`

  The *only* data we need is the `RouteModel`.
-}
generateSiteFromModel ::
  forall r m.
  (MonadIO m, MonadLoggerIO m, MonadFail m, Eq r, Show r, IsRoute r, EmaStaticSite r) =>
  -- | Target directory to write files to. Must exist.
  FilePath ->
  -- | The model data used to generate assets.
  RouteModel r ->
  m [FilePath]
generateSiteFromModel :: forall r (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m, MonadFail m, Eq r, Show r, IsRoute r,
 EmaStaticSite r) =>
FilePath -> RouteModel r -> m [FilePath]
generateSiteFromModel FilePath
dest RouteModel r
model =
  forall {f :: Type -> Type} {a}. MonadIO f => f a -> f a
withBlockBuffering forall a b. (a -> b) -> a -> b
$ do
    forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (forall r (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m, MonadError Text m, Eq r, Show r,
 EmaStaticSite r) =>
FilePath -> RouteModel r -> m [FilePath]
generateSiteFromModel' @r FilePath
dest RouteModel r
model) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Text
err -> do
        forall (m :: Type -> Type) a.
(MonadLoggerIO m, MonadFail m) =>
Text -> Text -> m a
crash Text
"ema" Text
err
      Right [FilePath]
fs ->
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [FilePath]
fs
  where
    -- Temporarily use block buffering before calling an IO action that is
    -- known ahead to log rapidly, so as to not hamper serial processing speed.
    withBlockBuffering :: f a -> f a
withBlockBuffering f a
f =
      forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout (Maybe Int -> BufferMode
BlockBuffering forall a. Maybe a
Nothing)
        forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> f a
f
        forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* (forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> forall (m :: Type -> Type). MonadIO m => Handle -> m ()
hFlush Handle
stdout)

-- | Like `generateSiteFromModel` but without buffering or error handling.
generateSiteFromModel' ::
  forall r m.
  (MonadIO m, MonadLoggerIO m, MonadError Text m, Eq r, Show r, EmaStaticSite r) =>
  FilePath ->
  RouteModel r ->
  -- | List of generated files.
  m [FilePath]
generateSiteFromModel' :: forall r (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m, MonadError Text m, Eq r, Show r,
 EmaStaticSite r) =>
FilePath -> RouteModel r -> m [FilePath]
generateSiteFromModel' FilePath
dest RouteModel r
model = do
  let enc :: RouteModel r -> Prism_ FilePath r
enc = forall r. IsRoute r => RouteModel r -> Prism_ FilePath r
routePrism @r
      rp :: Prism' FilePath r
rp = forall s a. Prism_ s a -> Prism' s a
fromPrism_ forall a b. (a -> b) -> a -> b
$ RouteModel r -> Prism_ FilePath r
enc RouteModel r
model
  -- Sanity checks
  forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
dest) forall a b. (a -> b) -> a -> b
$ do
    forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text
"Destination directory does not exist: " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText FilePath
dest
  let routes :: [r]
routes = forall r. IsRoute r => RouteModel r -> [r]
routeUniverse @r RouteModel r
model
  forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [r]
routes) forall a b. (a -> b) -> a -> b
$
    forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError Text
"Your app's `routeUniverse` is empty; nothing to generate!"
  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [r]
routes forall a b. (a -> b) -> a -> b
$ \r
route ->
    forall r a.
(HasCallStack, Eq r, Show r) =>
(a -> Prism_ FilePath r) -> a -> r -> Either Text ()
checkRoutePrismGivenRoute RouteModel r -> Prism_ FilePath r
enc RouteModel r
model r
route
      forall (f :: Type -> Type) l r.
Applicative f =>
Either l r -> (l -> f ()) -> f ()
`whenLeft_` forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError
  -- For Github Pages
  forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
FilePath -> m ()
noBirdbrainedJekyll FilePath
dest
  -- Enumerate and write all routes.
  forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ Text
"Writing " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [r]
routes) forall a. Semigroup a => a -> a -> a
<> Text
" routes"
  forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [r]
routes forall a b. (a -> b) -> a -> b
$ \r
r -> do
    let fp :: FilePath
fp = FilePath
dest FilePath -> FilePath -> FilePath
</> forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Prism' FilePath r
rp r
r
    forall r (m :: Type -> Type).
(EmaSite r, MonadIO m, MonadLoggerIO m) =>
Prism' FilePath r -> RouteModel r -> r -> m (SiteOutput r)
siteOutput Prism' FilePath r
rp RouteModel r
model r
r forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      AssetStatic FilePath
staticPath -> do
        forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesPathExist FilePath
staticPath) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True ->
            -- NOTE: A static path can indeed be a directory. The user is not
            -- obliged to recursively list the files.
            forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
FilePath -> FilePath -> m ()
copyRecursively FilePath
staticPath FilePath
fp
          Bool
False ->
            forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelError forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ FilePath
"? " forall a. Semigroup a => a -> a -> a
<> FilePath
staticPath forall a. Semigroup a => a -> a -> a
<> FilePath
" (missing)"
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
      AssetGenerated Format
_fmt !LByteString
s -> do
        forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> LByteString -> m ()
writeFileGenerated FilePath
fp LByteString
s
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [FilePath
fp]

{- | Disable birdbrained hacks from GitHub to disable surprises like,
 https://github.com/jekyll/jekyll/issues/55
-}
noBirdbrainedJekyll :: (MonadIO m, MonadLoggerIO m) => FilePath -> m ()
noBirdbrainedJekyll :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
FilePath -> m ()
noBirdbrainedJekyll FilePath
dest = do
  let nojekyll :: FilePath
nojekyll = FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath
".nojekyll"
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
nojekyll) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> forall (f :: Type -> Type). Applicative f => f ()
pass
    Bool
False -> do
      forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ Text
"Disabling Jekyll by writing " forall a. Semigroup a => a -> a -> a
<> forall a. ToText a => a -> Text
toText FilePath
nojekyll
      forall (m :: Type -> Type).
MonadIO m =>
FilePath -> LByteString -> m ()
writeFileLBS FilePath
nojekyll LByteString
""

newtype StaticAssetMissing = StaticAssetMissing FilePath
  deriving stock (Int -> StaticAssetMissing -> FilePath -> FilePath
[StaticAssetMissing] -> FilePath -> FilePath
StaticAssetMissing -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [StaticAssetMissing] -> FilePath -> FilePath
$cshowList :: [StaticAssetMissing] -> FilePath -> FilePath
show :: StaticAssetMissing -> FilePath
$cshow :: StaticAssetMissing -> FilePath
showsPrec :: Int -> StaticAssetMissing -> FilePath -> FilePath
$cshowsPrec :: Int -> StaticAssetMissing -> FilePath -> FilePath
Show)
  deriving anyclass (Show StaticAssetMissing
Typeable @Type StaticAssetMissing
SomeException -> Maybe StaticAssetMissing
StaticAssetMissing -> FilePath
StaticAssetMissing -> SomeException
forall e.
Typeable @Type e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> FilePath)
-> Exception e
displayException :: StaticAssetMissing -> FilePath
$cdisplayException :: StaticAssetMissing -> FilePath
fromException :: SomeException -> Maybe StaticAssetMissing
$cfromException :: SomeException -> Maybe StaticAssetMissing
toException :: StaticAssetMissing -> SomeException
$ctoException :: StaticAssetMissing -> SomeException
Exception)

writeFileGenerated :: (MonadLogger m, MonadIO m) => FilePath -> LByteString -> m ()
writeFileGenerated :: forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> LByteString -> m ()
writeFileGenerated FilePath
fp LByteString
s = do
  forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ FilePath
"W " forall a. Semigroup a => a -> a -> a
<> FilePath
fp
  forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
fp)
    forall (m :: Type -> Type).
MonadIO m =>
FilePath -> LByteString -> m ()
writeFileLBS FilePath
fp LByteString
s

{- | Copy a file or directory recursively to the target directory

  Like `cp -R src dest`.
-}
copyRecursively ::
  forall m.
  ( MonadIO m
  , MonadLoggerIO m
  ) =>
  -- | Absolute path to source file or directory to copy.
  FilePath ->
  -- | Target file or directory path.
  FilePath ->
  m ()
copyRecursively :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
FilePath -> FilePath -> m ()
copyRecursively FilePath
src FilePath
dest = do
  [(FilePath, FilePath)]
fs <- FilePath -> FilePath -> m [(FilePath, FilePath)]
enumerateFilesToCopy FilePath
src FilePath
dest
  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(FilePath, FilePath)]
fs forall a b. (a -> b) -> a -> b
$ \(FilePath
a, FilePath
b) -> do
    forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo forall a b. (a -> b) -> a -> b
$ forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ FilePath
"C " forall a. Semigroup a => a -> a -> a
<> FilePath
b
    forall {m :: Type -> Type}.
MonadIO m =>
FilePath -> FilePath -> m ()
copyFileCreatingParents FilePath
a FilePath
b
  where
    enumerateFilesToCopy :: FilePath -> FilePath -> m [(FilePath, FilePath)]
    enumerateFilesToCopy :: FilePath -> FilePath -> m [(FilePath, FilePath)]
enumerateFilesToCopy FilePath
a FilePath
b = do
      forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
a) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True ->
          forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [(FilePath
a, FilePath
b)]
        Bool
False -> do
          forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesDirectoryExist FilePath
a) forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False ->
              forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> StaticAssetMissing
StaticAssetMissing FilePath
a
            Bool
True -> do
              [FilePath]
fs <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO [FilePath]
getDirectoryFiles FilePath
src [FilePath
"**"]
              forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [FilePath]
fs forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \FilePath
fp -> (FilePath
a FilePath -> FilePath -> FilePath
</> FilePath
fp, FilePath
b FilePath -> FilePath -> FilePath
</> FilePath
fp)

    copyFileCreatingParents :: FilePath -> FilePath -> m ()
copyFileCreatingParents FilePath
a FilePath
b =
      forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
b)
        FilePath -> FilePath -> IO ()
copyFile FilePath
a FilePath
b