{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wredundant-constraints #-}
module Web.Rep.Socket
( socketPage,
serveSocketBox,
sharedServer,
defaultSharedServer,
SocketConfig(..),
defaultSocketConfig,
defaultSocketPage,
defaultInputCode,
defaultOutputCode,
Code(..),
code,
wrangle,
)
where
import qualified Network.WebSockets as WS
import Box
import Box.Socket
import Control.Lens
import Control.Monad.Conc.Class as C
import Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import NumHask.Prelude hiding (intercalate, replace)
import Text.InterpolatedString.Perl6
import Web.Rep.Html
import Web.Rep.Page
import Web.Rep.Server
import Web.Rep.Shared
import Web.Rep.Bootstrap
import Web.Scotty hiding (get)
import qualified Data.Attoparsec.Text as A
import Network.Wai.Handler.WebSockets
import Lucid as L
socketPage :: Page
socketPage = mempty & #jsOnLoad .~
mconcat
[ webSocket,
runScriptJs,
refreshJsbJs,
preventEnter
]
serveSocketBox :: SocketConfig -> Page -> Box IO Text Text -> IO ()
serveSocketBox cfg p b =
scotty (cfg ^. #port) $ do
middleware $ websocketsOr WS.defaultConnectionOptions (serverApp b)
servePageWith "/" (defaultPageConfig "") p
sharedServer :: SharedRep IO a -> SocketConfig -> Page -> (Html () -> [Code]) -> (Either Text a -> IO [Code]) -> IO ()
sharedServer srep cfg p i o =
serveSocketBox cfg p <$.>
fromAction (backendLoop srep i o . wrangle)
defaultSharedServer :: (Show a) => SharedRep IO a -> IO ()
defaultSharedServer srep =
sharedServer srep defaultSocketConfig defaultSocketPage defaultInputCode defaultOutputCode
defaultSocketPage :: Page
defaultSocketPage =
bootstrapPage <>
socketPage &
#htmlBody
.~ divClass_
"container"
( mconcat
[ divClass_ "row" (h1_ "web-rep testing"),
divClass_ "row" $ mconcat $ (\(t, h) -> divClass_ "col" (h2_ (toHtml t) <> L.with div_ [id_ t] h)) <$> sections
]
)
where
sections =
[ ("input", mempty),
("output", mempty)
]
backendLoop ::
(MonadConc m) =>
SharedRep m a ->
(Html () -> [Code]) ->
(Either Text a -> m [Code]) ->
Box m [Code] (Text, Text) -> m ()
backendLoop sr inputCode outputCode (Box c e) = flip evalStateT (0, HashMap.empty) $ do
(Rep h fa) <- unshare sr
b <- lift $ commit c (inputCode h)
o <- step' fa
b' <- lift $ commit c o
when (b && b') (go fa)
where
go fa = do
incoming <- lift $ emit e
modify (updateS incoming)
o <- step' fa
b <- lift $ commit c o
when b (go fa)
updateS Nothing s = s
updateS (Just (k,v)) s = second (insert k v) s
step' fa = do
s <- get
let (m', ea) = fa (snd s)
modify (second (const m'))
o <- lift $ outputCode ea
pure o
defaultInputCode :: Html () -> [Code]
defaultInputCode h = [Append "input" (toText h)]
defaultOutputCode :: (Monad m, Show a) => Either Text a -> m [Code]
defaultOutputCode ea =
pure $ case ea of
Left err -> [Append "debug" err]
Right a -> [Replace "output" (show a)]
wrangle :: Monad m => Box m Text Text -> Box m [Code] (Text,Text)
wrangle (Box c e) = Box c' e'
where
c' = listC $ contramap code c
e' = mapE (pure . either (const Nothing) Just) (parseE parserJ e)
parserJ :: A.Parser (Text,Text)
parserJ = do
_ <- A.string [q|{"event":{"element":"|]
e <- A.takeTill (=='"')
_ <- A.string [q|","value":"|]
v <- A.takeTill (=='"')
_ <- A.string [q|"}}|]
pure (e,v)
data Code =
Replace Text Text |
Append Text Text |
Console Text |
Eval Text |
Val Text
deriving (Eq, Show, Generic, Read)
code :: Code -> Text
code (Replace i t) = replace i t
code (Append i t) = append i t
code (Console t) = console t
code (Eval t) = t
code (Val t) = val t
console :: Text -> Text
console t = [qc| console.log({t}) |]
val :: Text -> Text
val t = [qc| jsb.ws.send({t}) |]
replace :: Text -> Text -> Text
replace d t =
[qc|
var $container = document.getElementById('{d}');
$container.innerHTML = '{clean t}';
runScripts($container);
refreshJsb();
|]
append :: Text -> Text -> Text
append d t =
[qc|
var $container = document.getElementById('{d}');
$container.innerHTML += '{clean t}';
runScripts($container);
refreshJsb();
|]
clean :: Text -> Text
clean =
Text.intercalate "\\'" . Text.split (== '\'')
. Text.intercalate "\\n"
. Text.lines
webSocket :: RepJs
webSocket =
RepJsText
[q|
window.jsb = {ws: new WebSocket('ws://' + location.host + '/')};
jsb.event = function(ev) {
jsb.ws.send(JSON.stringify({event: ev}));
};
jsb.ws.onmessage = function(evt){
eval('(function(){' + evt.data + '})()');
};
|]
refreshJsbJs :: RepJs
refreshJsbJs =
RepJsText
[q|
function refreshJsb () {
$('.jsbClassEventInput').off('input');
$('.jsbClassEventInput').on('input', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventChange').off('change');
$('.jsbClassEventChange').on('change', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventFocusout').off('focusout');
$('.jsbClassEventFocusout').on('focusout', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventButton').off('click');
$('.jsbClassEventButton').on('click', (function(){
jsb.event({ 'element': this.id, 'value': this.value});
}));
$('.jsbClassEventToggle').off('click');
$('.jsbClassEventToggle').on('click', (function(){
jsb.event({ 'element': this.id, 'value': ('true' !== this.getAttribute('aria-pressed')).toString()});
}));
$('.jsbClassEventCheckbox').off('click');
$('.jsbClassEventCheckbox').on('click', (function(){
jsb.event({ 'element': this.id, 'value': this.checked.toString()});
}));
$('.jsbClassEventChooseFile').off('input');
$('.jsbClassEventChooseFile').on('input', (function(){
jsb.event({ 'element': this.id, 'value': this.files[0].name});
}));
$('.jsbClassEventShowSum').off('change');
$('.jsbClassEventShowSum').on('change', (function(){
var v = this.value;
$(this).parent('.sumtype-group').siblings('.subtype').each(function(i) {
if (this.dataset.sumtype === v) {
this.style.display = 'block';
} else {
this.style.display = 'none';
}
})
}));
$('.jsbClassEventChangeMultiple').off('change');
$('.jsbClassEventChangeMultiple').on('change', (function(){
jsb.event({ 'element': this.id, 'value': [...this.options].filter(option => option.selected).map(option => option.value).join(',')});
}));
};
|]
preventEnter :: RepJs
preventEnter =
RepJs $
parseJs
[q|
window.addEventListener('keydown',function(e) {
if(e.keyIdentifier=='U+000A' || e.keyIdentifier=='Enter' || e.keyCode==13) {
if(e.target.nodeName=='INPUT' && e.target.type !== 'textarea') {
e.preventDefault();
return false;
}
}
}, true);
|]
runScriptJs :: RepJs
runScriptJs =
RepJsText
[q|
function insertScript ($script) {
var s = document.createElement('script')
s.type = 'text/javascript'
if ($script.src) {
s.onload = callback
s.onerror = callback
s.src = $script.src
} else {
s.textContent = $script.innerText
}
// re-insert the script tag so it executes.
document.head.appendChild(s)
// clean-up
$script.parentNode.removeChild($script)
}
function runScripts ($container) {
// get scripts tags from a node
var $scripts = $container.querySelectorAll('script')
$scripts.forEach(function ($script) {
insertScript($script)
})
}
|]