{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Ema.App
  ( runEma,
    runEmaPure,
    runEmaWithCli,
  )
where

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Control.Monad.Logger (MonadLoggerIO, logInfoN)
import Control.Monad.Logger.Extras
  ( colorize,
    logToStdout,
    runLoggerLoggingT,
  )
import Data.LVar (LVar)
import qualified Data.LVar as LVar
import Ema.Asset (Asset (AssetGenerated), Format (Html))
import Ema.CLI (Cli)
import qualified Ema.CLI as CLI
import Ema.Class (Ema)
import qualified Ema.Generate as Generate
import qualified Ema.Server as Server
import System.Directory (getCurrentDirectory)
import System.Environment (lookupEnv)
import UnliftIO (BufferMode (BlockBuffering, LineBuffering), MonadUnliftIO, hFlush, hSetBuffering)

-- | Pure version of @runEmaWith@ (i.e with no model).
--
-- Due to purity, there is no impure state, and thus no time-varying model.
-- Neither is there a concept of route, as only a single route (index.html) is
-- expected, whose HTML contents is specified as the only argument to this
-- function.
runEmaPure ::
  -- | How to render a route
  (CLI.Action -> LByteString) ->
  IO ()
runEmaPure :: (Action -> LByteString) -> IO ()
runEmaPure Action -> LByteString
render = do
  (Action -> () -> () -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar () -> m ())
-> IO ()
forall model route.
(Ema model route, Show route) =>
(Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar model -> m ())
-> IO ()
runEma (\Action
act () () -> Format -> LByteString -> Asset LByteString
forall a. Format -> a -> Asset a
AssetGenerated Format
Html (LByteString -> Asset LByteString)
-> LByteString -> Asset LByteString
forall a b. (a -> b) -> a -> b
$ Action -> LByteString
render Action
act) ((forall (m :: * -> *).
  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
  Action -> LVar () -> m ())
 -> IO ())
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar () -> m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Action
act LVar ()
model -> do
    LVar () -> () -> m ()
forall (m :: * -> *) a. MonadIO m => LVar a -> a -> m ()
LVar.set LVar ()
model ()
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Action
act Action -> Action -> Bool
forall a. Eq a => a -> a -> Bool
== Action
CLI.Run) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound

-- | Convenient version of @runEmaWith@ that takes initial model and an update
-- function. You typically want to use this.
--
-- It uses @race_@ to properly clean up the update action when the ema thread
-- exits, and vice-versa.
runEma ::
  forall model route.
  (Ema model route, Show route) =>
  -- | How to render a route, given the model
  (CLI.Action -> model -> route -> Asset LByteString) ->
  -- | A long-running IO action that will update the @model@ @LVar@ over time.
  -- This IO action must set the initial model value in the very beginning.
  (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => CLI.Action -> LVar model -> m ()) ->
  IO ()
runEma :: (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar model -> m ())
-> IO ()
runEma Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
runModel = do
  Cli
cli <- IO Cli
CLI.cliAction
  Cli
-> (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar model -> m ())
-> IO ()
forall model route.
(Ema model route, Show route) =>
Cli
-> (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar model -> m ())
-> IO ()
runEmaWithCli Cli
cli Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
runModel

-- | Like @runEma@ but takes the CLI action
--
-- Useful if you are handling CLI arguments yourself.
runEmaWithCli ::
  forall model route.
  (Ema model route, Show route) =>
  Cli ->
  -- | How to render a route, given the model
  (CLI.Action -> model -> route -> Asset LByteString) ->
  -- | A long-running IO action that will update the @model@ @LVar@ over time.
  -- This IO action must set the initial model value in the very beginning.
  (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => CLI.Action -> LVar model -> m ()) ->
  IO ()
runEmaWithCli :: Cli
-> (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar model -> m ())
-> IO ()
runEmaWithCli Cli
cli Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
runModel = do
  LVar model
model <- IO (LVar model)
forall (m :: * -> *) a. MonadIO m => m (LVar a)
LVar.empty
  -- TODO: Allow library users to control logging levels, or colors.
  let logger :: Logger
logger = Logger -> Logger
colorize Logger
logToStdout
  (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath
cwd <- IO FilePath -> LoggingT IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCurrentDirectory
    Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoN (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Launching Ema under: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
cwd
    Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoN Text
"Waiting for initial model ..."
  IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_
    ((LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Action -> LVar model -> LoggingT IO ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
runModel (Cli -> Action
CLI.action Cli
cli) LVar model
model)
    ((LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Action
-> LVar model
-> (Action -> model -> route -> Asset LByteString)
-> LoggingT IO ()
forall model route (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route,
 Show route) =>
Action
-> LVar model
-> (Action -> model -> route -> Asset LByteString)
-> m ()
runEmaWithCliInCwd (Cli -> Action
CLI.action Cli
cli) LVar model
model Action -> model -> route -> Asset LByteString
render)

-- | Run Ema live dev server
runEmaWithCliInCwd ::
  forall model route m.
  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route, Show route) =>
  -- | CLI arguments
  CLI.Action ->
  -- | Your site model type, as a @LVar@ in order to support modifications over
  -- time (for hot-reload).
  --
  -- Use @Data.LVar.new@ to create it, and then -- over time -- @Data.LVar.set@
  -- or @Data.LVar.modify@ to modify it. Ema will automatically hot-reload your
  -- site as this model data changes.
  LVar model ->
  -- | Your site render function. Takes the current @model@ value, and the page
  -- @route@ type as arguments. It must return the raw HTML to render to browser
  -- or generate on disk.
  (CLI.Action -> model -> route -> Asset LByteString) ->
  m ()
runEmaWithCliInCwd :: Action
-> LVar model
-> (Action -> model -> route -> Asset LByteString)
-> m ()
runEmaWithCliInCwd Action
cliAction LVar model
model Action -> model -> route -> Asset LByteString
render = do
  model
val <- LVar model -> m model
forall (m :: * -> *) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoN Text
"... initial model is now available."
  case Action
cliAction of
    CLI.Generate FilePath
dest -> do
      m () -> m ()
forall (f :: * -> *) a. MonadIO f => f a -> f a
withBlockBuffering (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> model -> (model -> route -> Asset LByteString) -> m ()
forall model route (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route,
 HasCallStack) =>
FilePath -> model -> (model -> route -> Asset LByteString) -> m ()
Generate.generate FilePath
dest model
val (Action -> model -> route -> Asset LByteString
render Action
cliAction)
    Action
CLI.Run -> do
      Int
port <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
8000 (Maybe Int -> Int)
-> (Maybe FilePath -> Maybe Int) -> Maybe FilePath -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Read Int => FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe @Int (FilePath -> Maybe Int) -> Maybe FilePath -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe FilePath -> Int) -> IO (Maybe FilePath) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"PORT"
      FilePath
host <- 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 -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"127.0.0.1" (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"HOST"
      FilePath
-> Int
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
forall model route (m :: * -> *).
(Ema model route, Show route, MonadIO m, MonadUnliftIO m,
 MonadLoggerIO m) =>
FilePath
-> Int
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
Server.runServerWithWebSocketHotReload FilePath
host Int
port LVar model
model (Action -> model -> route -> Asset LByteString
render Action
cliAction)
  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 :: * -> *). 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 :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
f
        f a -> f () -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Handle -> BufferMode -> f ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering f () -> f () -> f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> f ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout)