{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Web.Suavemente.Core where
import Control.Applicative (liftA2)
import Control.Concurrent.STM.TVar (TVar, writeTVar)
import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.STM (atomically)
import Control.Monad.State (evalStateT)
import Data.Aeson (Value, decode, Result (..))
import Data.Aeson.Types (Parser, parse)
import qualified Data.ByteString.Char8 as B
import qualified Data.Map.Strict as M
import Data.Proxy (Proxy (..))
import Network.Wai.Handler.Warp (run)
import Network.WebSockets (Connection, receiveData, sendTextData)
import Servant (Get, Handler, Capture, (:<|>)(..), (:>), serve, err404)
import Servant.API.WebSocket (WebSocket)
import Servant.HTML.Blaze (HTML)
import qualified Streaming as S
import qualified Streaming.Prelude as S
import Text.Blaze (preEscapedString, Markup, ToMarkup (..))
import Text.Blaze.Renderer.String (renderMarkup)
import Text.InterpolatedString.Perl6 (qc, q)
import Web.Suavemente.Types
showMarkup :: ToMarkup a => a -> String
showMarkup = renderMarkup . toMarkup
fromResult :: Result a -> a
fromResult (Success a) = a
fromResult (Error s) = error s
getEvents
:: (Value -> Parser a)
-> TVar a
-> String
-> IO ()
-> S.Stream (S.Of ChangeEvent) IO ()
-> S.Stream (S.Of ChangeEvent) IO ()
getEvents p t n update
= S.mapMaybeM (
\a@(ChangeEvent i z) ->
case i == n of
True -> do
liftIO . atomically . writeTVar t . fromResult $ parse p z
update
pure Nothing
False -> pure $ Just a
)
htmlPage :: (a -> Markup) -> String -> a -> Markup
htmlPage pp res a = preEscapedString $
[q|
<style>
</style>|]
++
[q|
<script>
// from https://code.lengstorf.com/get-form-values-as-json/
const isCheckbox = e => e.type === 'checkbox';
const isMultiSelect = e => e.options && e.multiple;
const getSelectValues = options => [].reduce.call(options, (values, option) => {
return option.selected ? values.concat(option.value) : values;
}, []);
let ws = new WebSocket("ws://localhost:8080/|] ++ res ++ [q|/ws");
const keepAlive = () => {
ws.send(JSON.stringify({}));
setTimeout(keepAlive, 1000);
};
ws.onopen = e => keepAlive();
ws.onmessage = e => document.getElementById("result").innerHTML = e.data;
const onChangeFunc = e => {
let element = e.target;
let result = null;
if (isCheckbox(element)) {
result = element.checked;
} else if (isMultiSelect(element)) {
result = getSelectValues(element);
} else if (element.type === 'range') {
result = parseFloat(element.value);
} else {
result = element.value;
}
if (result !== null) {
ws.send(JSON.stringify({ "element": element.id, "payload": result }));
}
}
</script>
|]
++
[qc|
<div id="result">{renderMarkup $ pp a}</div>
<table>
|]
type API = Get '[HTML] Markup
:<|> "" :> "ws" :> WebSocket
type API2 = Capture "resource" String :> Get '[HTML] Markup
:<|> Capture "resource" String :> "ws" :> WebSocket
suavemente :: (a -> Markup) -> Suave a -> IO ()
suavemente pp w = do
let ws = M.singleton "" $ SomeSuave pp w
run 8080
. serve (Proxy @API)
$ htmlHandler ws "" :<|> socketHandler ws ""
suavementely :: M.Map String SomeSuave -> IO ()
suavementely w = do
run 8080
. serve (Proxy @API2)
$ htmlHandler w :<|> socketHandler w
socketHandler
:: M.Map String SomeSuave
-> String
-> Connection
-> Handler ()
socketHandler ws s c =
case M.lookup s ws of
Nothing -> throwError err404
Just (SomeSuave pp w) -> liftIO $ do
Input _ f a <- atomically $ evalStateT (suavely w) 0
S.effects
. f (sendTextData c . B.pack . renderMarkup . pp =<< atomically a)
. S.mapM (liftA2 (>>) print pure)
. S.mapMaybe id
. S.repeatM
. fmap decode
$ receiveData c
htmlHandler :: M.Map String SomeSuave -> String -> Handler Markup
htmlHandler ws res =
case M.lookup res ws of
Nothing -> throwError err404
Just (SomeSuave pp w) -> liftIO $ do
Input html _ a <- atomically $ evalStateT (suavely w) 0
a0 <- atomically a
pure $ htmlPage pp res a0 <> html