{-# 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 :: LogLevel -> Text -> m ()
log = Text -> LogLevel -> Text -> m ()
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 :: FilePath -> RouteModel r -> m [FilePath]
generateSiteFromModel FilePath
dest RouteModel r
model =
  m [FilePath] -> m [FilePath]
forall {f :: Type -> Type} {a}. MonadIO f => f a -> f a
withBlockBuffering (m [FilePath] -> m [FilePath]) -> m [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ do
    ExceptT Text m [FilePath] -> m (Either Text [FilePath])
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (FilePath -> RouteModel r -> ExceptT Text m [FilePath]
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) m (Either Text [FilePath])
-> (Either Text [FilePath] -> m [FilePath]) -> m [FilePath]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Text
err -> do
        Text -> Text -> m [FilePath]
forall (m :: Type -> Type) a.
(MonadLoggerIO m, MonadFail m) =>
Text -> Text -> m a
crash Text
"ema" Text
err
      Right [FilePath]
fs ->
        [FilePath] -> m [FilePath]
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 =
      Handle -> BufferMode -> f ()
forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout (Maybe Int -> BufferMode
BlockBuffering Maybe Int
forall a. Maybe a
Nothing)
        f () -> f a -> f a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> f a
f
        f a -> f () -> f a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* (Handle -> BufferMode -> f ()
forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering f () -> f () -> f ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Handle -> f ()
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' :: FilePath -> RouteModel r -> m [FilePath]
generateSiteFromModel' FilePath
dest RouteModel r
model = do
  let enc :: RouteModel r -> Prism_ FilePath r
enc = IsRoute r => RouteModel r -> Prism_ FilePath r
forall r. IsRoute r => RouteModel r -> Prism_ FilePath r
routePrism @r
      rp :: Prism' FilePath r
rp = Prism_ FilePath r -> Prism' FilePath r
forall s a. Prism_ s a -> Prism' s a
fromPrism_ (Prism_ FilePath r -> Prism' FilePath r)
-> Prism_ FilePath r -> Prism' FilePath r
forall a b. (a -> b) -> a -> b
$ RouteModel r -> Prism_ FilePath r
enc RouteModel r
model
  -- Sanity checks
  m Bool -> m () -> m ()
forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
unlessM (IO Bool -> m Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
dest) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> m ()
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Destination directory does not exist: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
dest
  let routes :: [r]
routes = RouteModel r -> [r]
forall r. IsRoute r => RouteModel r -> [r]
routeUniverse @r RouteModel r
model
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when ([r] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [r]
routes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Text -> m ()
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError Text
"Your app's `routeUniverse` is empty; nothing to generate!"
  [r] -> (r -> m ()) -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [r]
routes ((r -> m ()) -> m ()) -> (r -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \r
route ->
    (RouteModel r -> Prism_ FilePath r)
-> RouteModel r -> r -> Either Text ()
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
      Either Text () -> (Text -> m ()) -> m ()
forall (f :: Type -> Type) l r.
Applicative f =>
Either l r -> (l -> f ()) -> f ()
`whenLeft_` Text -> m ()
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError
  -- For Github Pages
  FilePath -> m ()
forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
FilePath -> m ()
noBirdbrainedJekyll FilePath
dest
  -- Enumerate and write all routes.
  LogLevel -> Text -> m ()
forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Writing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show ([r] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [r]
routes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" routes"
  ([[FilePath]] -> [FilePath]) -> m [[FilePath]] -> m [FilePath]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [[FilePath]] -> [FilePath]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (m [[FilePath]] -> m [FilePath])
-> ((r -> m [FilePath]) -> m [[FilePath]])
-> (r -> m [FilePath])
-> m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [r] -> (r -> m [FilePath]) -> m [[FilePath]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [r]
routes ((r -> m [FilePath]) -> m [FilePath])
-> (r -> m [FilePath]) -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ \r
r -> do
    let fp :: FilePath
fp = FilePath
dest FilePath -> FilePath -> FilePath
</> Prism' FilePath r -> r -> 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
    Prism' FilePath r -> RouteModel r -> r -> m (SiteOutput 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 m (Asset LByteString)
-> (Asset LByteString -> m [FilePath]) -> m [FilePath]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      AssetStatic FilePath
staticPath -> do
        IO Bool -> m Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesPathExist FilePath
staticPath) m Bool -> (Bool -> m ()) -> m ()
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.
            FilePath -> FilePath -> m ()
forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
FilePath -> FilePath -> m ()
copyRecursively FilePath
staticPath FilePath
fp
          Bool
False ->
            LogLevel -> Text -> m ()
forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelError (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"? " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
staticPath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" (missing)"
        [FilePath] -> m [FilePath]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
      AssetGenerated Format
_fmt !LByteString
s -> do
        FilePath -> LByteString -> m ()
forall (m :: Type -> Type).
(MonadLogger m, MonadIO m) =>
FilePath -> LByteString -> m ()
writeFileGenerated FilePath
fp LByteString
s
        [FilePath] -> m [FilePath]
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 :: FilePath -> m ()
noBirdbrainedJekyll FilePath
dest = do
  let nojekyll :: FilePath
nojekyll = FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath
".nojekyll"
  IO Bool -> m Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
nojekyll) m Bool -> (Bool -> m ()) -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> m ()
forall (f :: Type -> Type). Applicative f => f ()
pass
    Bool
False -> do
      LogLevel -> Text -> m ()
forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Disabling Jekyll by writing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
nojekyll
      FilePath -> LByteString -> m ()
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
(Int -> StaticAssetMissing -> FilePath -> FilePath)
-> (StaticAssetMissing -> FilePath)
-> ([StaticAssetMissing] -> FilePath -> FilePath)
-> Show StaticAssetMissing
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
Typeable @Type StaticAssetMissing
-> Show StaticAssetMissing
-> (StaticAssetMissing -> SomeException)
-> (SomeException -> Maybe StaticAssetMissing)
-> (StaticAssetMissing -> FilePath)
-> Exception 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
$cp2Exception :: Show StaticAssetMissing
$cp1Exception :: Typeable @Type StaticAssetMissing
Exception)

writeFileGenerated :: (MonadLogger m, MonadIO m) => FilePath -> LByteString -> m ()
writeFileGenerated :: FilePath -> LByteString -> m ()
writeFileGenerated FilePath
fp LByteString
s = do
  LogLevel -> Text -> m ()
forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"W " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fp
  IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
fp)
    FilePath -> LByteString -> IO ()
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 :: FilePath -> FilePath -> m ()
copyRecursively FilePath
src FilePath
dest = do
  [(FilePath, FilePath)]
fs <- FilePath -> FilePath -> m [(FilePath, FilePath)]
enumerateFilesToCopy FilePath
src FilePath
dest
  [(FilePath, FilePath)] -> ((FilePath, FilePath) -> m ()) -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(FilePath, FilePath)]
fs (((FilePath, FilePath) -> m ()) -> m ())
-> ((FilePath, FilePath) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
a, FilePath
b) -> do
    LogLevel -> Text -> m ()
forall (m :: Type -> Type).
MonadLogger m =>
LogLevel -> Text -> m ()
log LogLevel
LevelInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"C " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
b
    FilePath -> FilePath -> m ()
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
      IO Bool -> m Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
a) m Bool
-> (Bool -> m [(FilePath, FilePath)]) -> m [(FilePath, FilePath)]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True ->
          [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [(FilePath
a, FilePath
b)]
        Bool
False -> do
          IO Bool -> m Bool
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesDirectoryExist FilePath
a) m Bool
-> (Bool -> m [(FilePath, FilePath)]) -> m [(FilePath, FilePath)]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False ->
              IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ StaticAssetMissing -> IO [(FilePath, FilePath)]
forall e a. Exception e => e -> IO a
throwIO (StaticAssetMissing -> IO [(FilePath, FilePath)])
-> StaticAssetMissing -> IO [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ FilePath -> StaticAssetMissing
StaticAssetMissing FilePath
a
            Bool
True -> do
              [FilePath]
fs <- IO [FilePath] -> m [FilePath]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO [FilePath]
getDirectoryFiles FilePath
src [FilePath
"**"]
              [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(FilePath, FilePath)] -> m [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ [FilePath]
fs [FilePath]
-> (FilePath -> (FilePath, FilePath)) -> [(FilePath, FilePath)]
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 =
      IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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