{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | The Sunroof server module provides infrastructure to use
-- Sunroof together with kansas-comet.
--
-- It supports setting up a simple server with 'sunroofServer'
-- and provides basic functions for serverside communication
-- with the connected website ('syncJS', 'asyncJS' and 'rsyncJS').
--
-- This module also provides the abstractions for 'Downlink'
-- and 'Uplink'. They represent directed channels for sending data
-- from the server to the website and the other way aroun.
-- The sent data is queued and operations block properly if there
-- is no data available.
module Language.Sunroof.Server
(
-- * Basic Comet Server
syncJS
, asyncJS
, rsyncJS
, SunroofResult(..)
, SunroofEngine(..)
, jsonToJS
, sunroofServer
, SunroofServerOptions(..)
, SunroofApp
, debugSunroofEngine
-- * Downlink
, Downlink
, newDownlink
, getDownlink
, putDownlink
-- * Uplink
, Uplink
, newUplink
, getUplink
, putUplink
-- * Timing
, Timings(..)
, newTimings
, resetTimings
, getTimings
) where
import Data.Aeson.Types ( Value(..), Object, Array )
import Data.Attoparsec.Number ( Number(..) )
import Data.List ( intercalate )
import Data.Text ( unpack )
import Data.Proxy ( Proxy(..) )
import Data.Default ( Default(..) )
import Data.Semigroup
import Data.Time.Clock
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as M
import System.FilePath((>))
import Control.Monad.IO.Class ( liftIO )
import Control.Concurrent.STM
import Network.Wai.Handler.Warp ( Port, settingsPort )
import Network.Wai.Middleware.Static
import qualified Web.Scotty as SC
import Web.KansasComet
( send, connect
, Document, Options
, kCometPlugin )
import qualified Web.KansasComet as KC
import Language.Sunroof
import Language.Sunroof.JavaScript
( Expr
, literal, showExpr
, scopeForEffect )
import Language.Sunroof.Classes ( Uniq )
import Language.Sunroof.Compiler ( compileJS )
-- -------------------------------------------------------------
-- Communication and Compilation
-- -------------------------------------------------------------
-- | The 'SunroofEngine' provides the verbosity level and
-- kansas comet document to the 'SunroofApp'.
data SunroofEngine = SunroofEngine
{ cometDocument :: Document
-- ^ The document comet uses to manage the connected website.
, uVar :: TVar Uniq
-- ^ Unique number supply for our engine
, engineVerbose :: Int
-- ^ @0@ for none, @1@ for initializations,
-- @2@ for commands done and @3@ for a complete log.
, compilerOpts :: CompilerOpts
-- ^ The options used to setup the compiler.
, timings :: Maybe (TVar (Timings NominalDiffTime))
-- ^ Performance timings of the compiler and communication.
}
-- | Generate one unique integer from the document.
docUniq :: SunroofEngine -> IO Int
docUniq = docUniqs 1
-- | Generate n unique integers from the document.
docUniqs :: Int -> SunroofEngine -> IO Int
docUniqs n doc = atomically $ do
u <- readTVar (uVar doc)
writeTVar (uVar doc) (u + n)
return u
-- | The number of uniques allocated for the first try of a compilation.
compileUniqAlloc :: Uniq
compileUniqAlloc = 32
-- | Log the given message on the given level
sunroofLog :: SunroofEngine -> Int -> String -> IO ()
sunroofLog engine level msg =
if (engineVerbose engine >= level)
then do
putStr "Sunroof> "
putStrLn msg
else return ()
-- | Log the compilation result and return it
compileLog :: SunroofEngine -> String -> IO ()
compileLog engine src = do
sequence_ $ fmap (sunroofLog engine 3) $
[ "Compiled:", src]
return ()
-- | Compile js using unique variables each time.
compileRequestJS :: SunroofEngine -> JS t () -> IO String
compileRequestJS engine jsm = do
-- Allocate a standard amount of uniq for compilation
uq <- docUniqs compileUniqAlloc engine
-- Compile
(stmts, uq') <- compileJS (compilerOpts engine) uq return jsm
-- Check if the allocated amount was sufficient
let txt = showExpr False $ scopeForEffect stmts
if (uq' < uq + compileUniqAlloc)
-- It was sufficient we are finished
then do compileLog engine txt
return txt
-- It wasn't sufficient
else do
-- Allocate all that are needed
newUq <- docUniqs (uq' - uq) engine
-- Compile again
(stmts', _) <- compileJS (compilerOpts engine) newUq return jsm
let txt' = showExpr False $ scopeForEffect stmts'
compileLog engine txt'
return txt'
-- | Executes the Javascript in the browser without waiting for a result.
asyncJS :: SunroofEngine -> JS t () -> IO ()
asyncJS engine jsm = do
t0 <- getCurrentTime
src <- compileRequestJS engine jsm
addCompileTime engine t0
t1 <- getCurrentTime
send (cometDocument engine) src -- send it, and forget it
addSendTime engine t1
return ()
-- | Executes the Javascript in the browser and waits for the result value.
-- The result value is given the corresponding Haskell type,
-- if possible (see 'SunroofResult').
syncJS :: forall a t . (SunroofResult a) => SunroofEngine -> JS t a -> IO (ResultOf a)
syncJS engine jsm | typeOf (Proxy :: Proxy a) == Unit = do
_ <- syncJS engine (jsm >> return (0 :: JSNumber))
return $ jsonToValue (Proxy :: Proxy a) Null
syncJS engine jsm = do
up <- newUplink engine
t0 <- getCurrentTime
src <- compileRequestJS engine $ do
v <- jsm
up # putUplink v
addCompileTime engine t0
t1 <- getCurrentTime
send (cometDocument engine) src
addSendTime engine t1
t2 <- getCurrentTime
-- There is *no* race condition in here. If no-one is listening,
-- then the numbered event gets queued up.
r <- getUplink up
addWaitTime engine t2
return r
-- | Executes the Javascript in the browser and waits for the result.
-- The returned value is just a reference to the computed value.
-- This allows to precompile values like function in the browser.
rsyncJS :: forall a t . (Sunroof a) => SunroofEngine -> JS t a -> IO a
rsyncJS engine jsm = do
uq <- docUniq engine -- uniq for the value
let uq_lab = label ("remote_" <> cast (js uq))
up :: Uplink JSNumber <- newUplink engine
t0 <- getCurrentTime
src <- compileRequestJS engine $ do
v <- jsm
-- Store the value inside the window object
object "window" # uq_lab := v
up # putUplink 0
addCompileTime engine t0
t1 <- getCurrentTime
send (cometDocument engine) src
addSendTime engine t1
t2 <- getCurrentTime
-- There is *no* race condition in here. If no-one is listening,
-- then the numbered event gets queued up.
_ <- getUplink up
addWaitTime engine t2
return $ object "window" ! uq_lab
-- -----------------------------------------------------------------------
-- Default Server Instance
-- -----------------------------------------------------------------------
-- | A comet application takes the engine/document we are currently communicating
-- with and delivers the IO action to be executed as server application.
type SunroofApp = SunroofEngine -> IO ()
-- | The 'SunroofServerOptions' specify the configuration of the
-- sunroof comet server infrastructure.
--
-- See 'sunroofServer' and 'SunroofServerOptions' for further information.
data SunroofServerOptions = SunroofServerOptions
{ cometPort :: Port
-- ^ The port the server is reachable from.
, cometResourceBaseDir :: FilePath
-- ^ Will be used as base directory to search for all static files.
-- Make this path absolute to run the server from anywhere.
, cometIndexFile :: FilePath
-- ^ The file to be used as index file (or landing page).
-- This path is given relative to the 'cometResourceBaseDir'.
, cometPolicy :: Policy
-- ^ The default policy is to allow the @css@, @img@ and @js@
-- folders to be used by the server, as well as the noDots policy.
-- This policy can be overwritten to allow delivery of other files.
, cometOptions :: Options
-- ^ Provides the kansas comet options to use.
-- Default options are provided with the 'Data.Default.def' instance.
, sunroofVerbose :: Int
-- ^ @0@ for none, @1@ for initializations,
-- @2@ for commands done and @3@ for a complete log.
, sunroofCompilerOpts :: CompilerOpts
-- ^ The set of options to configure the Sunroof compiler.
-- Default options are provided with the 'Data.Default.def' instance.
}
-- | Sets up a comet server ready to use with sunroof.
--
-- @sunroofServer opts app@:
-- The @opts@ give various configuration for the comet server.
-- See 'SunroofServerOptions' for further information on this.
-- The application to run is given by @app@. It takes the current
-- engine/document as parameter. The document is needed for calls to 'syncJS',
-- 'asyncJS' and 'rsyncJS'.
--
-- The server provides the kansas comet Javascript on the path
-- @js/kansas-comet.js@.
--
-- Since @kansas-comet.js@ is a JQuery plugin you have to also
-- load a decent version of @jquery.js@ (or @jquery.min.js@)
-- and also @jquery-json.js@. They are available at:
--
-- *