{-# 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. Pages containing a
-- @head@ element are modified to include a bit of JavaScript. It serves at
-- auto-reloading the page when it is rebuilt (by connecting to a websocket).
module Slab.Serve
  ( run
  ) where

import Control.Concurrent.Chan qualified as Chan
import Control.Concurrent.STM qualified as STM
import Data.Map qualified as M
import Data.Text qualified as T
import Data.Text.Lazy.Encoding qualified as TLE
import Network.HTTP.Types (status200)
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
import Network.WebSockets.Connection
  ( Connection
  , sendTextData
  , withPingThread
  )
import Protolude hiding (Handler)
import Servant hiding (serve)
import Servant.API.WebSocket (WebSocket)
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.Evaluate qualified as Evaluate
import Slab.Render qualified as Render
import Slab.Syntax qualified as Syntax
import Slab.Watch qualified as Watch
import System.FilePath (takeExtension)
import Text.Blaze.Html5 (Html)
import Text.Pretty.Simple (pShowNoColor)
import WaiAppStatic.Storage.Filesystem
  ( defaultWebAppSettings
  )

------------------------------------------------------------------------------
run :: FilePath -> FilePath -> IO ()
run :: String -> String -> IO ()
run String
srcDir String
distDir = do
  TVar (Map String (Either Error [Block]))
store <- STM (TVar (Map String (Either Error [Block])))
-> IO (TVar (Map String (Either Error [Block])))
forall a. STM a -> IO a
atomically (STM (TVar (Map String (Either Error [Block])))
 -> IO (TVar (Map String (Either Error [Block]))))
-> STM (TVar (Map String (Either Error [Block])))
-> IO (TVar (Map String (Either Error [Block])))
forall a b. (a -> b) -> a -> b
$ Map String (Either Error [Block])
-> STM (TVar (Map String (Either Error [Block])))
forall a. a -> STM (TVar a)
STM.newTVar Map String (Either Error [Block])
forall k a. Map k a
M.empty
  Chan String
chan <- IO (Chan String)
forall a. IO (Chan a)
Chan.newChan
  -- Initial build to populate the store...
  String
-> RenderMode
-> RunMode
-> TVar (Map String (Either Error [Block]))
-> IO ()
Build.buildDirInMemory String
srcDir RenderMode
Command.RenderNormal RunMode
Command.RunPassthrough TVar (Map String (Either Error [Block]))
store
  -- ...then rebuild individual files upon change, and notify the channel.
  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 -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
path -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> String
takeExtension String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".slab") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
-> RenderMode
-> RunMode
-> TVar (Map String (Either Error [Block]))
-> String
-> IO ()
Build.buildFileInMemory String
srcDir RenderMode
Command.RenderNormal RunMode
Command.RunPassthrough TVar (Map String (Either Error [Block]))
store String
path
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> String
takeExtension String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
".slab") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          -- Rebuild everything. TODO create a dependency graph and rebuild
          -- only what is needed.
          String
-> RenderMode
-> RunMode
-> TVar (Map String (Either Error [Block]))
-> IO ()
Build.buildDirInMemory String
srcDir RenderMode
Command.RenderNormal RunMode
Command.RunPassthrough TVar (Map String (Either Error [Block]))
store
        Chan String -> String -> IO ()
forall a. Chan a -> a -> IO ()
Chan.writeChan Chan String
chan String
path
  Port -> Application -> IO ()
Warp.run Port
9000 (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ String
-> TVar (Map String (Either Error [Block]))
-> Chan String
-> Application
serve String
distDir TVar (Map String (Either Error [Block]))
store Chan String
chan

-- | Turn our `serverT` implementation into a Wai application, suitable for
-- Warp.run.
serve :: FilePath -> Build.StmStore -> Chan FilePath -> Wai.Application
serve :: String
-> TVar (Map String (Either Error [Block]))
-> Chan String
-> Application
serve String
root TVar (Map String (Either Error [Block]))
store Chan String
chan =
  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 (Either Error [Block]))
-> Chan String
-> Server App
serverT String
root TVar (Map String (Either Error [Block]))
store Chan String
chan

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

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

------------------------------------------------------------------------------
type App =
  "hello" :> Get '[B.HTML] Html
    :<|> WebSocketApi
    :<|> 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 -> Chan FilePath -> ServerT App Handler
serverT :: String
-> TVar (Map String (Either Error [Block]))
-> Chan String
-> Server App
serverT String
root TVar (Map String (Either Error [Block]))
store Chan String
chan =
  Handler Html
showHelloPage
    Handler Html
-> ((Connection -> Handler ()) :<|> Tagged Handler Application)
-> Handler Html
   :<|> ((Connection -> Handler ()) :<|> Tagged Handler Application)
forall a b. a -> b -> a :<|> b
:<|> Chan String -> Connection -> Handler ()
websocket Chan String
chan
    (Connection -> Handler ())
-> Tagged Handler Application
-> (Connection -> Handler ()) :<|> Tagged Handler Application
forall a b. a -> b -> a :<|> b
:<|> String
-> TVar (Map String (Either Error [Block]))
-> Tagged Handler Application
app String
root TVar (Map String (Either Error [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 (Either Error [Block]))
-> Tagged Handler Application
app String
root TVar (Map String (Either Error [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 (Either Error [Block])) -> Application
app' String
root TVar (Map String (Either Error [Block]))
store Request
req Response -> IO ResponseReceived
sendRes

app' :: FilePath -> Build.StmStore -> Application
app' :: String -> TVar (Map String (Either Error [Block])) -> Application
app' String
root TVar (Map String (Either Error [Block]))
store Request
req Response -> IO ResponseReceived
sendRes = do
  Map String (Either Error [Block])
templates <- IO (Map String (Either Error [Block]))
-> IO (Map String (Either Error [Block]))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (Either Error [Block]))
 -> IO (Map String (Either Error [Block])))
-> (STM (Map String (Either Error [Block]))
    -> IO (Map String (Either Error [Block])))
-> STM (Map String (Either Error [Block]))
-> IO (Map String (Either Error [Block]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Map String (Either Error [Block]))
-> IO (Map String (Either Error [Block]))
forall a. STM a -> IO a
atomically (STM (Map String (Either Error [Block]))
 -> IO (Map String (Either Error [Block])))
-> STM (Map String (Either Error [Block]))
-> IO (Map String (Either Error [Block]))
forall a b. (a -> b) -> a -> b
$ TVar (Map String (Either Error [Block]))
-> STM (Map String (Either Error [Block]))
forall a. TVar a -> STM a
STM.readTVar TVar (Map String (Either Error [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 (Either Error [Block])
-> Maybe (Either Error [Block])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> String
T.unpack Text
path') Map String (Either Error [Block])
templates of
    Just Either Error [Block]
mblocks -> do
      case Either Error [Block]
mblocks of
        Right [Block]
blocks -> do
          let blocks' :: [Block]
blocks' = Text -> [Block] -> [Block]
Syntax.addScript Text
autoreloadScript ([Block] -> [Block]) -> [Block] -> [Block]
forall a b. (a -> b) -> a -> b
$ [Block] -> [Block]
Evaluate.simplify [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')
        Left Error
err -> do
          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/plain")]
              (Text -> ByteString
TLE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Error -> Text
forall a. Show a => a -> Text
pShowNoColor Error
err)
    Maybe (Either Error [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

------------------------------------------------------------------------------
-- Accept websocket connections, and keep them alive.
type WebSocketApi = "ws" :> WebSocket

-- | Sends messages to the browser whenever a message is written to the channel.
websocket :: Chan FilePath -> Connection -> Handler ()
websocket :: Chan String -> Connection -> Handler ()
websocket Chan String
chan Connection
con =
  IO () -> Handler ()
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ do
    Chan String
chan' <- Chan String -> IO (Chan String)
forall a. Chan a -> IO (Chan a)
dupChan Chan String
chan
    Connection -> Port -> IO () -> IO () -> IO ()
forall a. Connection -> Port -> IO () -> IO a -> IO a
withPingThread Connection
con Port
30 (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String
path <- Chan String -> IO String
forall a. Chan a -> IO a
Chan.readChan Chan String
chan'
        Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
con (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"updated: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path)

-- | The auto-reload script. It connects to a websocket and refreshes the
-- current page when it receives a message from the server. Such a message is
-- sent whenever a @.slab@ file is rebuilt.
autoreloadScript :: Text
autoreloadScript :: Text
autoreloadScript =
  Text
"function connect(isInitialConnection) {\n\
  \  // Create WebSocket connection.\n\
  \  var ws = new WebSocket('ws://' + location.host + '/ws');\n\
  \\n\
  \  // Connection opened\n\
  \  ws.onopen = function() {\n\
  \    ws.send('Hello server.');\n\
  \    if (isInitialConnection) {\n\
  \      console.log('autoreload: Initial connection.');\n\
  \    } else {\n\
  \      console.log('autoreload: Reconnected.');\n\
  \      location.reload();\n\
  \    }\n\
  \  };\n\
  \\n\
  \  // Listen for messages.\n\
  \  ws.onmessage = function(ev) {\n\
  \    console.log('autoreload: Message from server:', ev.data);\n\
  \    if (ev.data.startsWith('updated:')) {\n\
  \      location.reload();\n\
  \    }\n\
  \  };\n\
  \\n\
  \  // Trying to reconnect when the socket is closed.\n\
  \  ws.onclose = function(ev) {\n\
  \    console.log('autoreload: Socket closed. Trying to reconnect in 0.5 second.');\n\
  \    setTimeout(function() { connect(false); }, 500);\n\
  \  };\n\
  \\n\
  \  // Close the socker upon error.\n\
  \  ws.onerror = function(err) {\n\
  \    console.log('autoreload: Socket errored. Closing socket.');\n\
  \    ws.close();\n\
  \  };\n\
  \}\n\
  \\n\
  \connect(true);\n"