module Language.Sunroof.Server
(
syncJS
, asyncJS
, rsyncJS
, SunroofResult(..)
, SunroofEngine(..)
, jsonToJS
, sunroofServer
, SunroofServerOptions(..)
, SunroofApp
, debugSunroofEngine
, Downlink
, newDownlink
, getDownlink
, putDownlink
, Uplink
, newUplink
, getUplink
, putUplink
, 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 )
data SunroofEngine = SunroofEngine
{ cometDocument :: Document
, uVar :: TVar Uniq
, engineVerbose :: Int
, compilerOpts :: CompilerOpts
, timings :: Maybe (TVar (Timings NominalDiffTime))
}
docUniq :: SunroofEngine -> IO Int
docUniq = docUniqs 1
docUniqs :: Int -> SunroofEngine -> IO Int
docUniqs n doc = atomically $ do
u <- readTVar (uVar doc)
writeTVar (uVar doc) (u + n)
return u
compileUniqAlloc :: Uniq
compileUniqAlloc = 32
sunroofLog :: SunroofEngine -> Int -> String -> IO ()
sunroofLog engine level msg =
if (engineVerbose engine >= level)
then do
putStr "Sunroof> "
putStrLn msg
else return ()
compileLog :: SunroofEngine -> String -> IO ()
compileLog engine src = do
sequence_ $ fmap (sunroofLog engine 3) $
[ "Compiled:", src]
return ()
compileRequestJS :: SunroofEngine -> JS t () -> IO String
compileRequestJS engine jsm = do
uq <- docUniqs compileUniqAlloc engine
(stmts, uq') <- compileJS (compilerOpts engine) uq return jsm
let txt = showExpr False $ scopeForEffect stmts
if (uq' < uq + compileUniqAlloc)
then do compileLog engine txt
return txt
else do
newUq <- docUniqs (uq' uq) engine
(stmts', _) <- compileJS (compilerOpts engine) newUq return jsm
let txt' = showExpr False $ scopeForEffect stmts'
compileLog engine txt'
return txt'
asyncJS :: SunroofEngine -> JS t () -> IO ()
asyncJS engine jsm = do
t0 <- getCurrentTime
src <- compileRequestJS engine jsm
addCompileTime engine t0
t1 <- getCurrentTime
send (cometDocument engine) src
addSendTime engine t1
return ()
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
r <- getUplink up
addWaitTime engine t2
return r
rsyncJS :: forall a t . (Sunroof a) => SunroofEngine -> JS t a -> IO a
rsyncJS engine jsm = do
uq <- docUniq engine
let uq_lab = label ("remote_" <> cast (js uq))
up :: Uplink JSNumber <- newUplink engine
t0 <- getCurrentTime
src <- compileRequestJS engine $ do
v <- jsm
object "window" # uq_lab := v
up # putUplink 0
addCompileTime engine t0
t1 <- getCurrentTime
send (cometDocument engine) src
addSendTime engine t1
t2 <- getCurrentTime
_ <- getUplink up
addWaitTime engine t2
return $ object "window" ! uq_lab
type SunroofApp = SunroofEngine -> IO ()
data SunroofServerOptions = SunroofServerOptions
{ cometPort :: Port
, cometResourceBaseDir :: FilePath
, cometIndexFile :: FilePath
, cometPolicy :: Policy
, cometOptions :: Options
, sunroofVerbose :: Int
, sunroofCompilerOpts :: CompilerOpts
}
sunroofServer :: SunroofServerOptions -> SunroofApp -> IO ()
sunroofServer opts cometApp = do
let warpSettings = (SC.settings def) { settingsPort = cometPort opts }
let scottyOptions = def { SC.verbose = 0
, SC.settings = warpSettings }
SC.scottyOpts scottyOptions $ do
kcomet <- liftIO kCometPlugin
let rootFile = cometResourceBaseDir opts </> cometIndexFile opts
let custom_policy = cometPolicy opts
let pol = only [("", rootFile)
,("js/kansas-comet.js", kcomet)]
<|> (custom_policy
>-> addBase (cometResourceBaseDir opts))
SC.middleware $ staticPolicy pol
connect (cometOptions opts) $ wrapDocument opts cometApp
wrapDocument :: SunroofServerOptions -> SunroofApp -> (Document -> IO ())
wrapDocument opts cometApp doc = do
uqVar <- atomically $ newTVar 0
cometApp $ SunroofEngine
{ cometDocument = doc
, uVar = uqVar
, engineVerbose = sunroofVerbose opts
, compilerOpts = sunroofCompilerOpts opts
, timings = Nothing
}
defaultServerOpts :: SunroofServerOptions
defaultServerOpts = SunroofServerOptions
{ cometPort = 3000
, cometResourceBaseDir = "."
, cometIndexFile = "index.html"
, cometPolicy = defaultPolicy
, cometOptions = def { KC.prefix = "/ajax", KC.verbose = 0 }
, sunroofVerbose = 0
, sunroofCompilerOpts = def
}
defaultPolicy :: Policy
defaultPolicy = noDots >-> (hasPrefix "css/" <|>
hasPrefix "js/" <|>
hasPrefix "img/")
instance Default SunroofServerOptions where
def = defaultServerOpts
data Downlink a = Downlink SunroofEngine (JSChan a)
newDownlink :: forall a . (Sunroof a, SunroofArgument a)
=> SunroofEngine -> IO (Downlink a)
newDownlink eng = do
chan <- rsyncJS eng (newChan :: JSA (JSChan a))
return $ Downlink eng chan
putDownlink :: (Sunroof a, SunroofArgument a)
=> Downlink a -> JSA a -> IO ()
putDownlink (Downlink eng chan) val = asyncJS eng $ do
v <- val
writeChan v chan
getDownlink :: (Sunroof a, SunroofArgument a)
=> Downlink a -> JSB a
getDownlink (Downlink _eng chan) = readChan chan
data Uplink a = Uplink SunroofEngine Uniq
newUplink :: SunroofEngine -> IO (Uplink a)
newUplink eng = do
u <- docUniq eng
return $ Uplink eng u
putUplink :: (Sunroof a) => a -> Uplink a -> JS t ()
putUplink a (Uplink _ u) = kc_reply (js u) a
getUplink :: forall a . (SunroofResult a) => Uplink a -> IO (ResultOf a)
getUplink (Uplink eng u) = do
val <- KC.getReply (cometDocument eng) u
return $ jsonToValue (Proxy :: Proxy a) val
kc_reply :: (Sunroof a) => JSNumber -> a -> JS t ()
kc_reply n a = fun "$.kc.reply" `apply` (n,a)
class (Sunroof a) => SunroofResult a where
type ResultOf a
jsonToValue :: Proxy a -> Value -> ResultOf a
instance SunroofResult () where
type ResultOf () = ()
jsonToValue _ (Null) = ()
jsonToValue _ v = error $ "jsonToValue: JSON value is not unit: " ++ show v
instance SunroofResult JSBool where
type ResultOf JSBool = Bool
jsonToValue _ (Bool b) = b
jsonToValue _ v = error $ "jsonToValue: JSON value is not a boolean: " ++ show v
instance SunroofResult JSNumber where
type ResultOf JSNumber = Double
jsonToValue _ (Number (I i)) = fromInteger i
jsonToValue _ (Number (D d)) = d
jsonToValue _ v = error $ "jsonToValue: JSON value is not a number: " ++ show v
instance SunroofResult JSString where
type ResultOf JSString = String
jsonToValue _ (String s) = unpack s
jsonToValue _ v = error $ "jsonToValue: JSON value is not a string: " ++ show v
instance forall a . SunroofResult a => SunroofResult (JSArray a) where
type ResultOf (JSArray a) = [ResultOf a]
jsonToValue _ (Array ss) = map (jsonToValue (Proxy :: Proxy a)) $ V.toList ss
jsonToValue _ v = error $ "jsonToValue: JSON value is not an array : " ++ show v
jsonToJS :: Value -> Expr
jsonToJS (Bool b) = unbox $ js b
jsonToJS (Number (I i)) = unbox $ js i
jsonToJS (Number (D d)) = unbox $ js d
jsonToJS (String s) = unbox $ js $ unpack s
jsonToJS (Null) = unbox $ nullJS
jsonToJS (Array arr) = jsonArrayToJS arr
jsonToJS (Object obj) = jsonObjectToJS obj
jsonObjectToJS :: Object -> Expr
jsonObjectToJS obj = literal $
let literalMap = M.toList $ fmap (show . jsonToJS) obj
convertKey k = "\"" ++ unpack k ++ "\""
keyValues = fmap (\(k,v) -> convertKey k ++ ":" ++ v) literalMap
in "{" ++ intercalate "," keyValues ++ "}"
jsonArrayToJS :: Array -> Expr
jsonArrayToJS arr = literal $
"(new Array(" ++ (intercalate "," $ V.toList $ fmap (show . jsonToJS) arr) ++ "))"
debugSunroofEngine :: IO SunroofEngine
debugSunroofEngine = do
doc <- KC.debugDocument
uqVar <- atomically $ newTVar 0
return $ SunroofEngine doc uqVar 3 def Nothing
data Timings a = Timings
{ compileTime :: !a
, sendTime :: !a
, waitTime :: !a
}
deriving Show
instance Functor Timings where
fmap f (Timings t1 t2 t3) = Timings (f t1) (f t2) (f t3)
instance Semigroup a => Semigroup (Timings a) where
(Timings t1 t2 t3) <> (Timings u1 u2 u3) = Timings (t1<>u1) (t2<>u2) (t3<>u3)
newTimings :: SunroofEngine -> IO SunroofEngine
newTimings e = do
v <- atomically $ newTVar $ Timings 0 0 0
return $ e { timings = Just v }
resetTimings :: SunroofEngine -> IO ()
resetTimings (SunroofEngine { timings = Nothing }) = return ()
resetTimings (SunroofEngine { timings = Just t }) = atomically $ writeTVar t $ Timings 0 0 0
getTimings :: SunroofEngine -> IO (Timings NominalDiffTime)
getTimings (SunroofEngine { timings = Nothing }) = return $ Timings 0 0 0
getTimings (SunroofEngine { timings = Just t }) = atomically $ readTVar t
addCompileTime :: SunroofEngine -> UTCTime -> IO ()
addCompileTime (SunroofEngine { timings = Nothing }) _start = return ()
addCompileTime (SunroofEngine { timings = Just t }) start = do
end <- getCurrentTime
atomically $ modifyTVar t $ \ ts -> ts { compileTime = compileTime ts + diffUTCTime end start}
return ()
addSendTime :: SunroofEngine -> UTCTime -> IO ()
addSendTime (SunroofEngine { timings = Nothing }) _start = return ()
addSendTime (SunroofEngine { timings = Just t }) start = do
end <- getCurrentTime
atomically $ modifyTVar t $ \ ts -> ts { sendTime = sendTime ts + diffUTCTime end start}
return ()
addWaitTime :: SunroofEngine -> UTCTime -> IO ()
addWaitTime (SunroofEngine { timings = Nothing }) _start = return ()
addWaitTime (SunroofEngine { timings = Just t }) start = do
end <- getCurrentTime
atomically $ modifyTVar t $ \ ts -> ts { waitTime = waitTime ts + diffUTCTime end start}
return ()