{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeApplications #-}

module Ema.Generate where

import Control.Exception (throw)
import Control.Monad.Logger
import Ema.Asset (Asset (..))
import Ema.Class (Ema (allRoutes, encodeRoute))
import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist)
import System.FilePath (takeDirectory, (</>))
import System.FilePattern.Directory (getDirectoryFiles)
import UnliftIO (MonadUnliftIO)

log :: MonadLogger m => LogLevel -> Text -> m ()
log :: LogLevel -> Text -> m ()
log = Text -> LogLevel -> Text -> m ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Text -> LogLevel -> msg -> m ()
logWithoutLoc Text
"Generate"

generate ::
  forall model route m.
  ( MonadIO m,
    MonadUnliftIO m,
    MonadLoggerIO m,
    Ema model route,
    HasCallStack
  ) =>
  FilePath ->
  model ->
  (model -> route -> Asset LByteString) ->
  -- | List of generated files.
  m [FilePath]
generate :: FilePath
-> model -> (model -> route -> Asset LByteString) -> m [FilePath]
generate FilePath
dest model
model model -> route -> Asset LByteString
render = do
  m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (IO Bool -> m Bool
forall (m :: * -> *) 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 a t. (HasCallStack, IsText t) => t -> a
error (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Destination 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 :: [route]
routes = model -> [route]
forall model route. Ema model route => model -> [route]
allRoutes model
model
  LogLevel -> Text -> m ()
forall (m :: * -> *). 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 ([route] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [route]
routes) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" routes"
  let ([(route, FilePath)]
staticPaths, [(FilePath, LByteString)]
generatedPaths) =
        [Either (route, FilePath) (FilePath, LByteString)]
-> [(route, FilePath)]
forall a b. [Either a b] -> [a]
lefts ([Either (route, FilePath) (FilePath, LByteString)]
 -> [(route, FilePath)])
-> ([Either (route, FilePath) (FilePath, LByteString)]
    -> [(FilePath, LByteString)])
-> [Either (route, FilePath) (FilePath, LByteString)]
-> ([(route, FilePath)], [(FilePath, LByteString)])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Either (route, FilePath) (FilePath, LByteString)]
-> [(FilePath, LByteString)]
forall a b. [Either a b] -> [b]
rights ([Either (route, FilePath) (FilePath, LByteString)]
 -> ([(route, FilePath)], [(FilePath, LByteString)]))
-> [Either (route, FilePath) (FilePath, LByteString)]
-> ([(route, FilePath)], [(FilePath, LByteString)])
forall a b. (a -> b) -> a -> b
$
          [route]
routes [route]
-> (route -> Either (route, FilePath) (FilePath, LByteString))
-> [Either (route, FilePath) (FilePath, LByteString)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \route
r ->
            case model -> route -> Asset LByteString
render model
model route
r of
              AssetStatic FilePath
fp -> (route, FilePath)
-> Either (route, FilePath) (FilePath, LByteString)
forall a b. a -> Either a b
Left (route
r, FilePath
fp)
              AssetGenerated Format
_fmt LByteString
s -> (FilePath, LByteString)
-> Either (route, FilePath) (FilePath, LByteString)
forall a b. b -> Either a b
Right (model -> route -> FilePath
forall model route. Ema model route => model -> route -> FilePath
encodeRoute model
model route
r, LByteString
s)
  [FilePath]
paths <- [(FilePath, LByteString)]
-> ((FilePath, LByteString) -> m FilePath) -> m [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FilePath, LByteString)]
generatedPaths (((FilePath, LByteString) -> m FilePath) -> m [FilePath])
-> ((FilePath, LByteString) -> m FilePath) -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ \(FilePath
relPath, !LByteString
s) -> do
    let fp :: FilePath
fp = FilePath
dest FilePath -> FilePath -> FilePath
</> FilePath
relPath
    LogLevel -> Text -> m ()
forall (m :: * -> *). 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 FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ do
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
fp)
      FilePath -> LByteString -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> LByteString -> m ()
writeFileLBS FilePath
fp LByteString
s
      FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
fp
  [(route, FilePath)] -> ((route, FilePath) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(route, FilePath)]
staticPaths (((route, FilePath) -> m ()) -> m ())
-> ((route, FilePath) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(route
r, FilePath
staticPath) -> do
    IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesPathExist FilePath
staticPath) m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True ->
        -- TODO: In current branch, we don't expect this to be a directory.
        -- Although the user may pass it, but review before merge.
        FilePath -> FilePath -> FilePath -> m ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, HasCallStack) =>
FilePath -> FilePath -> FilePath -> m ()
copyDirRecursively (model -> route -> FilePath
forall model route. Ema model route => model -> route -> FilePath
encodeRoute model
model route
r) FilePath
staticPath FilePath
dest
      Bool
False ->
        LogLevel -> Text -> m ()
forall (m :: * -> *). MonadLogger m => LogLevel -> Text -> m ()
log LogLevel
LevelWarn (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 ()
forall (m :: * -> *).
(MonadIO m, MonadLoggerIO m) =>
FilePath -> m ()
noBirdbrainedJekyll FilePath
dest
  [FilePath] -> m [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath]
paths

-- | 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 :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
nojekyll) m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Bool
False -> do
      LogLevel -> Text -> m ()
forall (m :: * -> *). 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 :: * -> *). MonadIO m => FilePath -> LByteString -> m ()
writeFileLBS FilePath
nojekyll LByteString
""

newtype StaticAssetMissing = StaticAssetMissing FilePath
  deriving (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, Show StaticAssetMissing
Typeable StaticAssetMissing
Typeable StaticAssetMissing
-> Show StaticAssetMissing
-> (StaticAssetMissing -> SomeException)
-> (SomeException -> Maybe StaticAssetMissing)
-> (StaticAssetMissing -> FilePath)
-> Exception StaticAssetMissing
SomeException -> Maybe StaticAssetMissing
StaticAssetMissing -> FilePath
StaticAssetMissing -> SomeException
forall e.
Typeable 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 StaticAssetMissing
Exception)

copyDirRecursively ::
  ( MonadIO m,
    MonadUnliftIO m,
    MonadLoggerIO m,
    HasCallStack
  ) =>
  -- | Source file path relative to CWD
  FilePath ->
  -- | Absolute path to source file to copy.
  FilePath ->
  -- | Directory *under* which the source file/dir will be copied
  FilePath ->
  m ()
copyDirRecursively :: FilePath -> FilePath -> FilePath -> m ()
copyDirRecursively FilePath
srcRel FilePath
srcAbs FilePath
destParent = do
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
srcAbs) m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> do
      let b :: FilePath
b = FilePath
destParent FilePath -> FilePath -> FilePath
</> FilePath
srcRel
      LogLevel -> Text -> m ()
forall (m :: * -> *). 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 :: * -> *). MonadIO m => FilePath -> FilePath -> m ()
copyFileCreatingParents FilePath
srcAbs FilePath
b
    Bool
False ->
      IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesDirectoryExist FilePath
srcAbs) m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False ->
          StaticAssetMissing -> m ()
forall a e. Exception e => e -> a
throw (StaticAssetMissing -> m ()) -> StaticAssetMissing -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> StaticAssetMissing
StaticAssetMissing FilePath
srcAbs
        Bool
True -> do
          [FilePath]
fs <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) 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
srcAbs [FilePath
"**"]
          [FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
fs ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> do
            let a :: FilePath
a = FilePath
srcAbs FilePath -> FilePath -> FilePath
</> FilePath
fp
                b :: FilePath
b = FilePath
destParent FilePath -> FilePath -> FilePath
</> FilePath
srcRel FilePath -> FilePath -> FilePath
</> FilePath
fp
            LogLevel -> Text -> m ()
forall (m :: * -> *). 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 :: * -> *). MonadIO m => FilePath -> FilePath -> m ()
copyFileCreatingParents FilePath
a FilePath
b
  where
    copyFileCreatingParents :: FilePath -> FilePath -> m ()
copyFileCreatingParents FilePath
a FilePath
b =
      IO () -> m ()
forall (m :: * -> *) 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