n2o-nitro (empty) → 0.11.0

raw patch · 5 files changed

+308/−0 lines, 5 filesdep +basedep +base64-bytestringdep +bertsetup-changed

Dependencies added: base, base64-bytestring, bert, binary, bytestring, containers, fmt, n2o, text

Files

LICENSE +30/−0
README.md +0/−0
Setup.hs +2/−0
n2o-nitro.cabal +38/−0
src/Network/N2O/Nitro.hs +238/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Marat Khafizov (c) 2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Marat Khafizov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ n2o-nitro.cabal view

@@ -0,0 +1,38 @@+name:           n2o-nitro
+version:        0.11.0
+description:    Nitro DSL
+homepage:       https://github.com/xafizoff/n2o#readme
+bug-reports:    https://github.com/xafizoff/n2o/issues
+author:         Marat Khafizov
+maintainer:     xafizoff@gmail.com
+copyright:      (c) Marat Khafizov, 2018
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+cabal-version:  >= 1.10
+extra-source-files:  README.md
+category:       Network, N2O, Web
+synopsis:       Nitro Elements, Events and Actions
+
+source-repository head
+  type: git
+  location: https://github.com/xafizoff/n2o
+
+library
+  exposed-modules:
+                  Network.N2O.Nitro
+  other-modules:
+      Paths_n2o_nitro
+  hs-source-dirs:
+      src
+  build-depends: base >= 4.7 && < 5
+               , n2o == 0.11.0
+               , text >= 1.2
+               , bytestring >= 0.10
+               , binary >= 0.5
+               , bert >= 1.2
+               , fmt >= 0.6.1
+               , containers >= 0.5
+               , base64-bytestring >= 1.0
+  default-language: Haskell2010
+

+ src/Network/N2O/Nitro.hs view

@@ -0,0 +1,238 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveGeneric,+  ScopedTypeVariables #-}++{-|+Module      : Network.N2O.Nitro+Description : Nitro DSL+Copyright   : (c) Marat Khafizov, 2018+License     : BSD-3+Maintainer  : xafizoff@gmail.com+Stability   : experimental+Portability : not portable++Nitro DSL to build interactive user interfaces++-}+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 Data.Text.Lazy.Encoding+import Fmt+import Fmt.Internal.Core+import GHC.Generics (Generic)+import Network.N2O hiding (Event)+import Numeric (showHex)+import Prelude hiding (id)++-- | An HTML element+data Element a+  = Element { name      :: String+            , id        :: String+            , body      :: [Element a]+            , postback  :: Maybe a+            , source    :: [String]+            , noBody    :: Bool+            , noClosing :: Bool+            }+  | Text TL.Text+  deriving (Show, Generic)++instance (B.Binary a) => B.Binary (Element a)++-- | Action that can be rendered as JavaScript events+data Action a+  = AEvent (Event a)+  | AElement (Element a)+  | ARaw BL.ByteString+  deriving (Show, Generic)++instance (B.Binary a) => B.Binary (Action a)++-- | A JavaScript event+data Event a = Event+  { eventTarget   :: String+  , eventPostback :: a+  , eventType     :: String+  , eventSource   :: [String]+  } deriving (Show, Generic)++instance (B.Binary a) => B.Binary (Event a)++-- | Wire an element+wireEl :: (B.Binary a) => Element a -> N2O f a (Result a)+wireEl = wire . AElement++-- | Wire action+wire :: forall f a. (B.Binary a) => Action a -> N2O f a (Result a)+wire a = do+  actions <- getActions+  putActions (a : actions)+  return Empty++-- | Render list of actions to JavaScript+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)++-- | Render an action+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 ""++-- | Render list of elements to the HTML+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)++-- | Render element to the HTML+renderElement :: (B.Binary a) => Element a -> N2O f a BL.ByteString+renderElement (Text t) = return $ 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 $+        encodeUtf8 $+        if noBody+          then "<" +| name |+ " " +| idProp id |+ "/>"+          else "<" +| name |+ " " +| idProp id |+ ">" +| decodeUtf8 content |+ "</" +| name |+ ">"+  where+    idProp :: String -> String+    idProp x =+      if x == ""+        then ""+        else "id=\"" +| x |+ "\""++-- | Render event+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 $ encodeUtf8 $+            "{ var x=qi('" +| eventTarget |+ "'); x && x.addEventListener('"+            +| eventType |+ "',function(event){ if (validateSources("+            +| strJoin (map (\x -> "'" ++ x ++  "'") eventSource) |++            ")) { ws.send(enc(tuple(atom('pickle'),bin('" +| eventTarget |+ "'),bin('"+            +| decodeUtf8 (pickle eventPostback) |+ "'),"+            +| strJoin (map renderSource src) |++            "))); } else console.log('Validation error'); })}"+  where+    renderSource s = "tuple(atom('" +| s |+ "'),querySource('" +| s |+ "'))"+    strJoin [] = "[]"+    strJoin l = "[" ++ intercalate "," l ++ "]"++-- | Element constructor+baseElement :: Element a+baseElement =+  Element+    { id = ""+    , name = undefined+    , postback = Nothing+    , body = []+    , source = []+    , noBody = False+    , noClosing = False+    }++-- | An HTML button+button :: Element a+button = baseElement {name = "button", source = []}++-- | A @panel@ widget+panel = baseElement {name = "div"}++-- | Text node+text :: TL.Text -> Element a+text = Text++-- | @<br>@ element+br = baseElement {name = "br", noBody = True, noClosing = True}++-- | A @textbox@ widget+textbox :: Element a+textbox = baseElement {name = "input type=\"text\"", noBody = True}++-- | Update text content of the element with the specified @id@+updateText :: (B.Binary a) => BL.ByteString -> TL.Text -> N2O f a (Result a)+updateText target s = wire+  (ARaw $ encodeUtf8 ("qi('" +| decodeUtf8 target |+ "').innerText='" +| s |+ "'"))++insertBottom :: (B.Binary a) => BL.ByteString -> Element a -> N2O f a (Result a)+insertBottom target elem = do+  content <- renderElement elem+  let tag = "div" :: TL.Text+      action =+        "(function(){ var div = qn('" +| tag |+ "'); div.innerHTML = '" +|+        decodeUtf8 content |+ "';qi('" +|+        decodeUtf8 target |+ "').appendChild(div.firstChild); })();"+  wire $ ARaw $ encodeUtf8 action++-- | Escape untrusted text to prevent XSS+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)++-- | Escape untrusted text to prevent XSS+jsEscape :: CL8.ByteString -> TL.Text+jsEscape = jsEscapeT . decodeUtf8++-- | Default pickler+defPickle :: (Show a) => a -> BL.ByteString+defPickle = B64.encode . CL8.pack . show++-- | Default depickler+defDePickle :: (Read a) => BL.ByteString -> Maybe a+defDePickle bs =+  case B64.decode bs of+    Right x -> Just $ read $ CL8.unpack x+    _ -> Nothing++-- | Get action list from the local mutable state+getActions :: (B.Binary a) => N2O f a [Action a]+getActions = do+  mbActions <- get (C8.pack "actions")+  return $+    case mbActions of+      Just actions -> actions+      _ -> []++-- | Put actions to the local mutable state+putActions :: (B.Binary a) => [Action a] -> N2O f a ()+putActions = put (C8.pack "actions")