{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveGeneric,
ScopedTypeVariables #-}
module Network.N2O.Nitro where
import Control.Monad (forM_, void)
import qualified Data.Binary as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.Lazy as B64
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as CL8
import Data.Char (isAlphaNum, ord, toLower)
import Data.IORef
import Data.List (intercalate)
import Data.Map.Strict ((!?))
import Data.String
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Encoding as T
import GHC.Generics (Generic)
import Network.N2O hiding (Event)
import Numeric (showHex)
import Prelude hiding (id)
data Element a
= Element { name :: BS.ByteString
, id :: BS.ByteString
, body :: [Element a]
, postback :: Maybe a
, source :: [BS.ByteString]
, noBody :: Bool
, noClosing :: Bool
}
| Text TL.Text
deriving (Show, Generic)
instance (B.Binary a) => B.Binary (Element a)
data Action a
= AEvent (Event a)
| AElement (Element a)
| ARaw BL.ByteString
deriving (Show, Generic)
instance (B.Binary a) => B.Binary (Action a)
data Event a = Event
{ eventTarget :: BS.ByteString
, eventPostback :: a
, eventType :: BS.ByteString
, eventSource :: [BS.ByteString]
} deriving (Show, Generic)
instance (B.Binary a) => B.Binary (Event a)
wireEl :: (B.Binary a) => Element a -> N2O f a (Result a)
wireEl = wire . AElement
wire :: forall f a. (B.Binary a) => Action a -> N2O f a (Result a)
wire a = do
actions <- getActions
putActions (a : actions)
return Empty
renderActions :: (B.Binary a) => [Action a] -> N2O f a BL.ByteString
renderActions [] = return ""
renderActions (a:as) = do
r <- renderAction a
rs <- renderActions as
return (r <> ";" <> rs)
renderAction :: (B.Binary a) => Action a -> N2O f a BL.ByteString
renderAction (ARaw bs) = return bs
renderAction (AEvent ev) = renderEvent ev
renderAction (AElement el@Element {..}) = do
case postback of
Nothing -> return ()
Just pb -> void (wire $ AEvent Event
{eventType = "click", eventPostback = pb, eventTarget = id, eventSource = source})
return ""
renderElements :: (B.Binary a) => [Element a] -> N2O f a BL.ByteString
renderElements [] = return ""
renderElements (e:es) = do
r <- renderElement e
rs <- renderElements es
return (r <> rs)
renderElement :: (B.Binary a) => Element a -> N2O f a BL.ByteString
renderElement (Text t) = return $ TL.encodeUtf8 t
renderElement Element {..} = do
case postback of
Nothing -> return ()
Just pb -> void (wire $ AEvent Event
{eventType = "click", eventPostback = pb, eventTarget = id, eventSource = source})
case name of
"br" -> return "<br>"
_ -> do
content <- renderElements body
return $
if noBody
then "<" <> BL.fromStrict name <> " " <> idProp id <> "/>"
else "<" <> BL.fromStrict name <> " " <> idProp id <> ">"
<> content <> "</" <> BL.fromStrict name <> ">"
where
idProp x =
if x == ""
then ""
else "id=\"" <> BL.fromStrict x <> "\""
renderEvent :: Event a -> N2O f a BL.ByteString
renderEvent Event {..} = do
ref <- ask
cx@Context {cxPickle = pickle} <- lift $ readIORef ref
case eventSource of
[] -> return BL.empty
src ->
return $
"{ var x=qi('" <> BL.fromStrict eventTarget <> "'); x && x.addEventListener('" <> BL.fromStrict eventType <>
"',function(event){ if (validateSources(" <> strJoin (map (\x -> "'" <> x <> "'") src) <>
")) { ws.send(enc(tuple(atom('pickle'),bin('" <> BL.fromStrict eventTarget <>
"'),bin('" <> pickle eventPostback <>
"')," <> strJoin (map renderSource src) <>
"))); } else console.log('Validation error'); })}"
where
renderSource :: BS.ByteString -> BS.ByteString
renderSource s = "tuple(atom('" <> s <> "'),querySource('" <> s <> "'))"
strJoin :: [BS.ByteString] -> BL.ByteString
strJoin = BL.fromStrict . BS.intercalate ","
baseElement :: Element a
baseElement =
Element
{ id = ""
, name = undefined
, postback = Nothing
, body = []
, source = []
, noBody = False
, noClosing = False
}
button :: Element a
button = baseElement {name = "button", source = []}
panel = baseElement {name = "div"}
text :: TL.Text -> Element a
text = Text
br = baseElement {name = "br", noBody = True, noClosing = True}
textbox :: Element a
textbox = baseElement {name = "input type=\"text\"", noBody = True}
updateText :: (B.Binary a) => BS.ByteString -> TL.Text -> N2O f a (Result a)
updateText target s = wire
(ARaw ("qi('" <> BL.fromStrict target <> "').innerText='"
<> TL.encodeUtf8 s <> "'"))
insertBottom :: (B.Binary a) => BS.ByteString -> Element a -> N2O f a (Result a)
insertBottom target elem = do
content <- renderElement elem
let action =
"(function(){ var div = qn('div'); div.innerHTML = '" <>
TL.decodeUtf8 content <> "';qi('" <>
TL.decodeUtf8 (BL.fromStrict target) <>
"').appendChild(div.firstChild); })();"
wire $ ARaw $ TL.encodeUtf8 action
jsEscapeT :: TL.Text -> TL.Text
jsEscapeT t = TL.pack (escape (TL.unpack t) "")
where
escape "" acc = acc
escape (x:xs) acc =
escape xs $
if isAlphaNum x
then acc ++ [x]
else acc <> "\\x" <> (flip showHex "" . ord $ x)
jsEscape :: CL8.ByteString -> TL.Text
jsEscape = jsEscapeT . TL.decodeUtf8
defPickle :: (Show a) => a -> BL.ByteString
defPickle = B64.encode . CL8.pack . show
defDePickle :: (Read a) => BL.ByteString -> Maybe a
defDePickle bs =
case B64.decode bs of
Right x -> Just $ read $ CL8.unpack x
_ -> Nothing
getActions :: (B.Binary a) => N2O f a [Action a]
getActions = do
mbActions <- get (C8.pack "actions")
return $
case mbActions of
Just actions -> actions
_ -> []
putActions :: (B.Binary a) => [Action a] -> N2O f a ()
putActions = put (C8.pack "actions")