{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- |
-- Module      : Slab.Serve
-- Description : Run a development server to preview Slab templates
--
-- @Slab.Serve@ watches a set of Slab templates, continuously rebuilding them
-- as they change, and runs a web server to serve them.
module Slab.Serve
  ( run
  ) where

import Control.Concurrent.STM qualified as STM
import Data.Map qualified as M
import Data.Text qualified as T
import Network.HTTP.Types (status200)
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
import Protolude hiding (Handler)
import Servant hiding (serve)
import Servant.HTML.Blaze qualified as B
import Servant.Server qualified as Server
import Slab.Build qualified as Build
import Slab.Command qualified as Command
import Slab.Render qualified as Render
import Slab.Watch qualified as Watch
import Text.Blaze.Html5 (Html)
import WaiAppStatic.Storage.Filesystem
  ( defaultWebAppSettings
  )

------------------------------------------------------------------------------
run :: FilePath -> FilePath -> IO ()
run :: String -> String -> IO ()
run String
srcDir String
distDir = do
  TVar (Map String [Block])
store <- STM (TVar (Map String [Block])) -> IO (TVar (Map String [Block]))
forall a. STM a -> IO a
atomically (STM (TVar (Map String [Block])) -> IO (TVar (Map String [Block])))
-> STM (TVar (Map String [Block]))
-> IO (TVar (Map String [Block]))
forall a b. (a -> b) -> a -> b
$ Map String [Block] -> STM (TVar (Map String [Block]))
forall a. a -> STM (TVar a)
STM.newTVar Map String [Block]
forall k a. Map k a
M.empty
  -- Initial build to populate the store.
  String -> RenderMode -> TVar (Map String [Block]) -> IO ()
Build.buildDirInMemory String
srcDir RenderMode
Command.RenderNormal TVar (Map String [Block])
store
  -- Then rebuild one file upon change.
  ThreadId
_ <-
    IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
      String -> (String -> IO ()) -> IO ()
Watch.run String
srcDir (String
-> RenderMode -> TVar (Map String [Block]) -> String -> IO ()
Build.buildFileInMemory String
srcDir RenderMode
Command.RenderNormal TVar (Map String [Block])
store)
  Port -> Application -> IO ()
Warp.run Port
9000 (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> TVar (Map String [Block]) -> Application
serve String
distDir TVar (Map String [Block])
store

-- | Turn our `serverT` implementation into a Wai application, suitable for
-- Warp.run.
serve :: FilePath -> Build.StmStore -> Wai.Application
serve :: String -> TVar (Map String [Block]) -> Application
serve String
root TVar (Map String [Block])
store =
  Proxy App -> Context '[] -> Server App -> Application
forall api (context :: [*]).
(HasServer api context, ServerContext context) =>
Proxy api -> Context context -> Server api -> Application
Servant.serveWithContext Proxy App
appProxy Context '[]
Server.EmptyContext (Server App -> Application) -> Server App -> Application
forall a b. (a -> b) -> a -> b
$
    Proxy App
-> Proxy '[]
-> (forall x. Handler x -> Handler x)
-> Server App
-> Server App
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy App
-> Proxy '[]
-> (forall x. m x -> n x)
-> ServerT App m
-> ServerT App n
Server.hoistServerWithContext Proxy App
appProxy Proxy '[]
settingsProxy Handler x -> Handler x
forall a. a -> a
forall x. Handler x -> Handler x
identity (Server App -> Server App) -> Server App -> Server App
forall a b. (a -> b) -> a -> b
$
      String -> TVar (Map String [Block]) -> Server App
serverT String
root TVar (Map String [Block])
store

------------------------------------------------------------------------------
type ServerSettings = '[]

settingsProxy :: Proxy ServerSettings
settingsProxy :: Proxy '[]
settingsProxy = Proxy '[]
forall {k} (t :: k). Proxy t
Proxy

------------------------------------------------------------------------------
type App =
  "hello" :> Get '[B.HTML] Html
    :<|> Servant.Raw -- Fallback handler for the static files.

appProxy :: Proxy App
appProxy :: Proxy App
appProxy = Proxy App
forall {k} (t :: k). Proxy t
Proxy

------------------------------------------------------------------------------
serverT :: FilePath -> Build.StmStore -> ServerT App Handler
serverT :: String -> TVar (Map String [Block]) -> Server App
serverT String
root TVar (Map String [Block])
store =
  Handler Html
showHelloPage
    Handler Html
-> Tagged Handler Application
-> Handler Html :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> String -> TVar (Map String [Block]) -> Tagged Handler Application
app String
root TVar (Map String [Block])
store

------------------------------------------------------------------------------
showHelloPage :: Handler Html
showHelloPage :: Handler Html
showHelloPage = Html -> Handler Html
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Html
"Hello."

------------------------------------------------------------------------------

-- | Try to serve a built page, and fallback to static files if the page
-- doesn't exist.
app :: FilePath -> Build.StmStore -> Server.Tagged Handler Server.Application
app :: String -> TVar (Map String [Block]) -> Tagged Handler Application
app String
root TVar (Map String [Block])
store = Application -> Tagged Handler Application
forall {k} (s :: k) b. b -> Tagged s b
Tagged (Application -> Tagged Handler Application)
-> Application -> Tagged Handler Application
forall a b. (a -> b) -> a -> b
$ \Request
req Response -> IO ResponseReceived
sendRes -> String -> TVar (Map String [Block]) -> Application
app' String
root TVar (Map String [Block])
store Request
req Response -> IO ResponseReceived
sendRes

app' :: FilePath -> Build.StmStore -> Application
app' :: String -> TVar (Map String [Block]) -> Application
app' String
root TVar (Map String [Block])
store Request
req Response -> IO ResponseReceived
sendRes = do
  Map String [Block]
templates <- IO (Map String [Block]) -> IO (Map String [Block])
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String [Block]) -> IO (Map String [Block]))
-> (STM (Map String [Block]) -> IO (Map String [Block]))
-> STM (Map String [Block])
-> IO (Map String [Block])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Map String [Block]) -> IO (Map String [Block])
forall a. STM a -> IO a
atomically (STM (Map String [Block]) -> IO (Map String [Block]))
-> STM (Map String [Block]) -> IO (Map String [Block])
forall a b. (a -> b) -> a -> b
$ TVar (Map String [Block]) -> STM (Map String [Block])
forall a. TVar a -> STM a
STM.readTVar TVar (Map String [Block])
store
  let path :: Text
path = Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
Wai.pathInfo Request
req
      path' :: Text
path' = if Text -> Bool
T.null Text
path then Text
"index.html" else Text
path
  -- TODO Check requestMethod is GET.
  case String -> Map String [Block] -> Maybe [Block]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> String
T.unpack Text
path') Map String [Block]
templates of
    Just [Block]
blocks ->
      Response -> IO ResponseReceived
sendRes (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS
          Status
status200
          [(HeaderName
"Content-Type", ByteString
"text/html")]
          ([Html] -> ByteString
Render.renderHtmlsUtf8 ([Html] -> ByteString) -> [Html] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Block] -> [Html]
Render.renderBlocks [Block]
blocks)
    Maybe [Block]
Nothing -> do
      let Tagged Application
staticApp = String -> Tagged Handler Application
serveStatic String
root
      Application
staticApp Request
req Response -> IO ResponseReceived
sendRes

------------------------------------------------------------------------------
serveStatic :: FilePath -> Server.Tagged Handler Server.Application
serveStatic :: String -> Tagged Handler Application
serveStatic String
root = StaticSettings -> ServerT Raw Handler
forall (m :: * -> *). StaticSettings -> ServerT Raw m
Servant.serveDirectoryWith StaticSettings
settings
 where
  settings :: StaticSettings
settings = String -> StaticSettings
defaultWebAppSettings String
root