front 0.0.0.1 → 0.0.0.2

raw patch · 9 files changed

+866/−10 lines, 9 filesdep +aesondep +asyncdep +base-compatdep ~basedep ~blaze-htmldep ~blaze-markupnew-component:exe:todo-servant-examplenew-component:exe:todo-yesod-examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, async, base-compat, base64-bytestring, cereal, conduit, cryptonite, data-default, directory, exceptions, fay-dom, fay-websockets, filepath, front, http-media, http-types, mtl, random, servant, servant-auth-cookie, servant-blaze, servant-server, stm, stm-lifted, time, transformers, unordered-containers, wai, wai-websockets, warp, websockets, yesod-core, yesod-static, yesod-websockets

Dependency ranges changed: base, blaze-html, blaze-markup, bytestring, fay, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−1
• README.md +86/−1
• examples/todo/ServantTodo.hs +280/−0
• examples/todo/Todo.hs +125/−0
• examples/todo/YesodTodo.hs +99/−0
• front.cabal +89/−2
• shared/Bridge.hs +78/−6
• src/Web/Front.hs +28/−0
• src/Web/Front/Broadcast.hs +74/−0

@@ -1,5 +1,11 @@ # Revision history for front -## 0.0.0.1 -- YYYY-mm-dd+## 0.0.0.2 -- 2019-04-10++* Integration with Servant established.+* `Todo` example decoupled from `servant` and `yesod`.+* Added abstraction for `Broadcast` communication.++## 0.0.0.1 -- 2019-02-25  * First version. Released on an unsuspecting world.

@@ -1,1 +1,86 @@-# front+# front (work-in-progress)++A front-end web framework which aim is to bring the power of GHC on client side with as less JavaScript as possible by the Fay.++The goal is to have a tiny websockets-based bridge between client and server to propagate client events on server for further handling.++## Features++- Server-side rendering.+- both SPA and regular webapp (sharing state across multiple routes).+- Several communication models (single session, broadcast, etc.).+- Virtual DOM with full/partial rendering.+- "blaze-html" like extended markup tree for handling both DOM and JS events.++## Usage++1. Add `front` as a dependency to your project using preferred build tool.+2. Obtain `bundle.js` by++```+curl https://raw.githubusercontent.com/swamp-agr/front/master/examples/todo/static/bundle.js+```++and include it as static resource in your application server. ++3. Import `Shared` module.+4. Choose proper communication model (Only session, Broadcast, etc.).+5. That's it.++## Examples++- `TODO`++  - Installation with Stack (`servant-auth-cookie` should be fixed to allow build with `cabal`):+  ```+  stack install --flag="front:examples"+  ```+  - usage:+  ```+  cd examples/todo+  # for servant-based:+  todo-servant-example+  # for yesod-based:+  todo-yesod-example+  # open web browser:+  open http://localhost:3000+  ```++## Developer Installation (Contribution)++For server:++```+cabal new-build+```++or++```+stack build+```++For client (issue: faylang/fay#459):++```+cabal sandbox init+cabal install # fay executable and libraries will be loaded+export HASKELL_PACKAGE_SANDBOX=`echo .cabal-sandbox/*-packages.conf.d/`+.cabal-sandbox/bin/fay \+  --package fay-dom,fay-websockets \+  --include shared,fay \+  -o bundle.js fay/Client.hs+```++Please do not hesitate to open Issue to discuss your questions or use cases.++## Acknowledgement++This ongoing framework would not have happened without these people and technologies:++- @5HT for inspiration by **N2O** framework. The idea of transfer both data and events over websockets.+- @jaspervdj for **blaze-html**.+- @meiersi for **blaze-react** and the approach how to handle events in the same markup with html.+- @snoyberg for **yesod-fay** and the way how to embed generated assert into server+and to trigger dependent Fay compilation from Haskell code.+- @bergmark for **Fay** compiler.

@@ -0,0 +1,280 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeOperators              #-}+module ServantTodo where++import           Conduit+import           Control.Concurrent                      (threadDelay)+import           Control.Monad                           (unless, when)+import           Control.Monad.Catch                     (catch)+import           Crypto.Random                           (drgNew)+import           Data.Data+import           Data.Default                            (def)+import qualified Data.HashMap.Strict                     as HashMap++import           Data.Text                               (Text)+import           Data.Text.Encoding                      (decodeUtf8)+import           Data.Time                               (defaultTimeLocale,+                                                          formatTime)+import           Data.Time.Clock                         (UTCTime (..),+                                                          getCurrentTime)+import           Network.Wai                             (Application)+import           Network.Wai.Handler.Warp+import           Network.Wai.Handler.WebSockets+import           Network.WebSockets                      hiding (Headers)+import           Prelude                                 hiding (interact)+import           Servant+import           Servant.HTML.Blaze+import           Servant.Server.Experimental.Auth        (mkAuthHandler)+import           Servant.Server.Experimental.Auth.Cookie+import           System.Directory                        (createDirectoryIfMissing,+                                                          doesFileExist,+                                                          getModificationTime,+                                                          listDirectory,+                                                          removeFile)+import           System.FilePath.Posix                   ((<.>), (</>))+import           System.Random                           (randomRIO)+import           Text.Blaze.Front.Html5                  ((!))+import           Text.Blaze.Front.Renderer               (renderNewMarkup)+import           Text.Blaze.Html5                        (Html)++import           Control.Concurrent.STM.Lifted           as STM+import qualified Data.ByteString.Base64                  as Base64+import qualified Data.ByteString.Char8                   as BSC8+import qualified Data.ByteString.Lazy                    as BL+import qualified Data.List                               as L+import qualified Data.Text                               as T+import qualified Text.Blaze.Front.Html5                  as H+import qualified Text.Blaze.Front.Html5.Attributes       as A++import           Bridge+import           Todo+import           Web.Front.Broadcast++type API = Header "cookie" T.Text :> Get '[HTML] (Cookied Html)+  :<|> "static" :> Raw++-- * App++data Config = Config+  { model              :: TVar Model+  , channel            :: TChan (Out (Action Msg))+  , static             :: FilePath+  , clients            :: TVar [Int]+  -- cookie settings+  , authCookieSettings :: AuthCookieSettings+  , generateKey        :: (IO ())  -- ^ An action to create a new key+  , randomSource       :: RandomSource+  , serverKeySet       :: FileKeySet+  }++-- * API++api :: Proxy API+api = Proxy++server :: Config -> Server API+server cfg = serveRoot cfg :<|> serveStatic cfg+  where+    addSession' = addSession+      (authCookieSettings cfg) -- the settings+      (randomSource cfg)       -- random source+      (serverKeySet cfg)       -- server key set++    serveRoot cfg'@Config{..} _mclient = do+      (clientId, state) <- liftIO $ do+        clientId <- clientSession cfg' _mclient+        setSession cfg' clientId+        state <- readTVarIO model+        pure (clientId, state)+      addSession'+        (def { ssExpirationType = MaxAge })+        clientId+        (renderNewMarkup $ do+        H.html $ do+          H.head $ do+            H.title "TODO"+            H.script ! A.src "/static/bundle.js" $ ""+          H.body $ do+            H.div ! A.id "root" $ renderModel state)++    serveStatic Config{..} = serveDirectoryWebApp static++addClient :: IO Int+addClient = randomRIO (0, 1000000)+++-- * Helpers++checkSession :: Config -> PendingConnection -> IO Int+checkSession cfg =+  clientSession cfg . fmap decodeUtf8 . HashMap.lookup "cookie"+  . HashMap.fromList . requestHeaders . pendingRequest++clientSession :: Config -> Maybe Text -> IO Int+clientSession cfg@Config{..} mclient = do+  result <- lookupSession cfg mclient+  case result of+    Nothing  -> addClient >>= (\x -> set cfg x >> pure x)+    Just cid -> pure cid+  where+    set conf clientNum = setSession conf clientNum++lookupSession :: Config -> Maybe Text -> IO (Maybe Int)+lookupSession Config{..} = \client -> do+  case client of+    Nothing  -> pure Nothing+    Just c   -> do+      msession <- getHeaderSession authCookieSettings serverKeySet c `catch` ex+      case epwSession <$> msession of+        Nothing -> pure Nothing+        Just cl -> pure $ pure cl+  where+    ex :: AuthCookieExceptionHandler IO+    ex _e = pure Nothing++setSession :: MonadIO m => Config -> Int -> m ()+setSession Config{..} clientId = atomically $ do+  ids <- readTVar clients+  unless (clientId `elem` ids) $ modifyTVar' clients (clientId :)+++-- * Main++main :: IO ()+main = do+  let fksp = FileKSParams+        { fkspKeySize = 16+        , fkspMaxKeys = 3+        , fkspPath = "./test-key-set"+        }+  cfg <- Config+    <$> STM.newTVarIO initModel+    <*> atomically newBroadcastTChan+    <*> pure "./static"+    <*> newTVarIO []+    -- cookie settings+    <*> (pure $ def { acsCookieFlags = ["HttpOnly"] })+    <*> pure (mkFileKey fksp)+    <*> mkRandomSource drgNew 1000+    <*> (mkFileKeySet fksp)++  putStrLn "Server up and running on http://localhost:3000/"+  run 3000 $ app cfg++-- | Custom handler that bluntly reports any occurred errors.+authHandler :: AuthCookieHandler (Maybe Int)+authHandler acs sks = mkAuthHandler $ \request ->+  (getSession acs sks request) `catch` handleEx >>= maybe+    (throwError err403 {errBody = "No cookies"})+    (return)+  where+    handleEx :: AuthCookieExceptionHandler Handler+    handleEx ex = throwError err403 {errBody = BL.fromStrict . BSC8.pack $ show ex}++app :: Config -> Application+app cfg@Config{..} = websocketsOr defaultConnectionOptions wsApp mainApp+  where+    wsApp :: ServerApp+    wsApp pendingConn = do+      let writeChan' = channel+      _client <- checkSession cfg pendingConn+      stream <- acceptRequest pendingConn+      forkPingThread stream 60 -- Ping+      readChan' <- atomically $ dupTChan writeChan'+      interact stream writeChan' readChan' model (_client)+    mainApp = serveWithContext+      (Proxy :: Proxy API)+      ((authHandler authCookieSettings serverKeySet) :. EmptyContext)+      (server cfg)++----------------------------------------------------------------------------+-- KeySet+-- A custom implementation of a keyset on top of 'RenewableKeySet'.+-- Keys are stored as files with base64 encoded data in 'test-key-set' directory.+-- To add a key just throw a file into the directory.+-- To remove a key delete corresponding file in the directory.+-- Both operations can be performed via web interface (see '/keys' page).+++data FileKSParams = FileKSParams+  { fkspPath    :: FilePath+  , fkspMaxKeys :: Int+  , fkspKeySize :: Int+  }++data FileKSState = FileKSState+  { fkssLastModified :: UTCTime } deriving Eq++type FileKeySet = RenewableKeySet FileKSState FileKSParams++mkFileKey :: FileKSParams -> IO ()+mkFileKey FileKSParams{..} = (,) <$> mkName <*> mkKey >>= uncurry writeFile where++  mkKey = generateRandomBytes fkspKeySize+    >>= return+      . BSC8.unpack+      . Base64.encode++  mkName = getCurrentTime+    >>= return+      . (fkspPath </>)+      . (<.> "b64")+      . formatTime defaultTimeLocale "%0Y%m%d%H%M%S"+    >>= \name -> do+      exists <- doesFileExist name+      if exists+        then (threadDelay 1000000) >> mkName+        -- ^ we don't want to change the keys that often+        else return name+++mkFileKeySet :: (MonadIO m, MonadThrow m)+  => FileKSParams+  -> m (RenewableKeySet FileKSState FileKSParams)+mkFileKeySet = mkKeySet where++  mkKeySet FileKSParams {..} = do+    liftIO $ do+      createDirectoryIfMissing True fkspPath+      listDirectory fkspPath >>= \fs -> when (null fs) $+        mkFileKey FileKSParams {..}++    let fkssLastModified = UTCTime (toEnum 0) 0++    mkRenewableKeySet+      RenewableKeySetHooks {..}+      FileKSParams {..}+      FileKSState {..}++  rkshNeedUpdate FileKSParams {..} (_, FileKSState {..}) = do+    lastModified <- liftIO $ getModificationTime fkspPath+    return (lastModified > fkssLastModified)++  getLastModifiedFiles FileKSParams {..} = listDirectory fkspPath+    >>= return . map (fkspPath </>)+    >>= \fs -> zip <$> (mapM getModificationTime fs) <*> (return fs)+    >>= return+      . map snd+      . L.take fkspMaxKeys+      . L.reverse+      . L.sort++  readKey = fmap (either (error "wrong key format") id . Base64.decode . BSC8.pack) . readFile++  rkshNewState FileKSParams {..} (_, s) = liftIO $ do+    lastModified <- getModificationTime fkspPath+    keys <- getLastModifiedFiles FileKSParams {..} >>= mapM readKey+    return (keys, s {fkssLastModified = lastModified})++  rkshRemoveKey FileKSParams {..} key = liftIO $ getLastModifiedFiles FileKSParams {..}+    >>= \fs -> zip fs <$> mapM readKey fs+    >>= return . filter ((== key) . snd)+    >>= mapM_ (removeFile . fst)

@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE RecordWildCards       #-}++module Todo where++import           Bridge+import           Control.Concurrent.STM.Lifted     as STM+import           Control.Monad                     (forM_, void)+import           Data.Char                         (isDigit)+import           Data.Data+import qualified Data.List                         as L+import           Data.Text                         (Text)+import qualified Data.Text                         as T+import           Fay.Convert                       (readFromFay')+import qualified Text.Blaze.Front.Event            as E+import           Text.Blaze.Front.Html5            (toValue, (!))+import qualified Text.Blaze.Front.Html5            as H+import qualified Text.Blaze.Front.Html5.Attributes as A+--import           Text.Blaze.Html5                  (Html)+++import           Web.Front+import           Web.Front.Broadcast++-- * Model++data Model = Model+  { entries :: [Entry]+  , nextId  :: Int+  }++data Entry = Entry+  { description :: Text+  , eid         :: Int+  }++data Msg = Add+  | Complete Int+  | Update Int RecordValue+  deriving (Show, Typeable, Data)++initModel :: Model+initModel = Model { entries = [], nextId = 0 }++-- * Event Handling++instance CommandHandler TVar Model Msg where+  onCommand cmd stateTVar client = do+    m@Model{..} <- STM.readTVarIO stateTVar+    case readFromFay' cmd of+      Left err -> do+        putStrLn $ "Error: " <> show err+        return (ExecuteClient client emptyTask ExecuteAll)+      Right (Send (Action _ _ acmd)) -> do+        case acmd of+          Add -> do+            let newTodo = Entry "TODO: " nextId+                newState = Model (newTodo : entries) (succ nextId)+                task = createTask "root" renderModel newState+            atomically $ void $ swapTVar stateTVar newState+            return (ExecuteClient client task ExecuteAll)+          Complete _eid -> do+            let newState = Model (filter ((/=_eid) . eid) entries) nextId+                task = createTask "root" renderModel newState+            atomically $ void $ swapTVar stateTVar newState+            return (ExecuteClient client task ExecuteAll)+          Update _eid val -> do+            let newState = Model ((upd _eid val) <$> entries) nextId+                upd _id val' e@Entry{..} =+                  if eid == _id then e { description = val', eid = _id } else e+                task = createTask "root" renderModel newState+            atomically $ void $ swapTVar stateTVar newState+            return (ExecuteClient client task ExecuteExcept)+      Right AskEvents -> do+        let task = createTask "root" renderModel m+        return $ ExecuteClient client task ExecuteAll+      Right PingPong -> return (ExecuteClient client emptyTask ExecuteAll)++-- * Rendering++renderModel :: Model -> H.Markup (Action Msg)+renderModel Model{..} = do+  H.h1 $ "TODO MVC: Servant"+  H.br+  forM_ entries $ \entry -> renderEntry entry+  let btnId = "todo-add"+  H.button+    ! A.id "todo-add"+    ! A.type_ "submit"+    ! E.onClick (Action btnId ObjectAction Add)+    $ "Add"++renderEntry :: Entry -> H.Markup (Action Msg)+renderEntry Entry{..} = do+  let elemId = "todo-" <> (T.pack $ show eid)+      removeId = "remove-" <> (T.pack $ show eid)+  H.input+    ! A.id (toValue elemId)+    ! A.type_ "text"+    ! A.value (toValue description)+    ! E.onKeyUp (Action elemId RecordAction (Update eid ""))+  H.button+    ! A.id (toValue removeId)+    ! A.type_ "submit"+    ! E.onClick (Action removeId ObjectAction (Complete eid))+    $ "Done"+  H.br++-- * Helpers++parseInt :: Text -> Int+parseInt = toInt . ignoreChars++toInt :: String -> Int+toInt a = read a :: Int++ignoreChars :: Text -> String+ignoreChars = L.filter isDigit . T.unpack++safeFromJust :: forall t. t -> Maybe t -> t+safeFromJust defv Nothing = defv+safeFromJust _ (Just a)   = a

@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}++module YesodTodo where++import           Conduit+import           Control.Concurrent.STM.Lifted as STM+import           Control.Monad.Reader+import           Prelude                       hiding (interact)+import           System.Random                 (randomRIO)+import           Text.Blaze.Front.Renderer     (renderNewMarkup)+import           Yesod.Core+import           Yesod.Static+import           Yesod.WebSockets++import qualified Data.Text                     as T++import           Bridge+import           Todo+import           Web.Front.Broadcast++-- * App++data App = App+  { appModel   :: TVar Model+  , appChannel :: TChan (Out (Action Msg))+  , appStatic  :: Static+  }++mkYesod "App" [parseRoutes|+/ HomeR GET+/static      StaticR  Static  appStatic+|]++-- * API++instance Yesod App where+  defaultLayout widget = do+    pc <- widgetToPageContent [whamlet|^{widget}|]+    withUrlRenderer [hamlet|<html>+  <head>+    ^{pageHead pc}+    <script src="/static/bundle.js">+  <body>+    <div #root>^{pageBody pc}+|]++-- * Handler for /++getHomeR :: Handler Html+getHomeR = do+  modelTVar <- appModel <$> getYesod+  model <- STM.readTVarIO modelTVar+  webSockets $ webApp modelTVar+  defaultLayout $ do+    setTitle "TODO"+    toWidget $ renderNewMarkup $ renderModel model++-- * WebSockets Web application++webApp :: TVar Model -> WebSocketsT (HandlerFor App) ()+webApp tvar = do+  conn <- ask+  cid <- clientSession+  writeChan' <- appChannel <$> getYesod+  readChan' <- atomically $ do+    dupTChan writeChan'+  liftIO $ interact conn writeChan' readChan' tvar cid++-- * Helpers++clientSession :: MonadHandler m => m Int+clientSession = do+  res <- lookupSession "client"+  case res of+    Nothing -> do+      (rnd :: Int) <- liftIO $ randomRIO (0,200000)+      let clientid = T.pack . show $ rnd+      setSession "client" clientid+      return rnd+    Just cid -> return $ parseInt cid++-- * Main++main :: IO ()+main = do+  (App+    <$> STM.newTVarIO initModel+    <*> atomically newBroadcastTChan+    <*> staticDevel "./static")+  >>= warp 3000

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/  name:                front-version:             0.0.0.1+version:             0.0.0.2 synopsis:            A reactive frontend web framework description:         A reactive frontend web framework. See haskell-front.org for more details. homepage:            haskell-front.org@@ -29,15 +29,102 @@                      , Text.Blaze.Front.Html5.Attributes                      , Text.Blaze.Front.Event                      , Text.Blaze.Front.Renderer+                     , Web.Front+                     , Web.Front.Broadcast                      -- shared                      , Bridge   -- other-modules:   other-extensions:    FlexibleInstances, TypeSynonymInstances, OverloadedStrings, GeneralizedNewtypeDeriving, Rank2Types, ExistentialQuantification, DeriveDataTypeable, MultiParamTypeClasses, DeriveFunctor, FunctionalDependencies, ScopedTypeVariables-  build-depends:       base >=4.11 && <4.12+  build-depends:       base <5+                     , aeson+                     , async+                     , stm+                     , stm-lifted+                     , conduit                      , text >=1.2 && <1.3+                     , mtl                      , bytestring >=0.10 && <0.11                      , blaze-markup >=0.8 && <0.10                      , blaze-html >=0.9 && <0.10                      , fay >= 0.24.0.2+                     , fay-dom+                     , fay-websockets+                     , websockets+  ghc-options:    -main-is YesodTodo -Wall   hs-source-dirs:      src, shared   default-language:    Haskell2010++flag examples+  default:+    False+  description:+    Builds front's examples++executable todo-servant-example+  main-is:             ServantTodo.hs+  if !flag(examples)+    buildable: False+  else+    hs-source-dirs:      examples/todo+    build-depends: base+                 , aeson+                 , conduit+                 , async+                 , websockets+                 , wai-websockets+                 , unordered-containers+                 , stm+                 , random+                 , stm-lifted     >=0.1.1.0+                 , fay+                 , base-compat    >= 0.9.1+                 , base64-bytestring+                 , blaze-html     >= 0.8 +                 , blaze-markup   >= 0.7 +                 , bytestring+                 , cereal         >= 0.5+                 , cryptonite     >= 0.14+                 , data-default+                 , directory+                 , exceptions+                 , filepath+                 , http-media+                 , http-types     >= 0.9+                 , mtl            >= 2.0+                 , servant        >= 0.5 +                 , servant-auth-cookie+                 , servant-blaze  >= 0.5 +                 , servant-server >= 0.5 +                 , text+                 , time+                 , transformers   >= 0.4 +                 , wai            >= 3.0 +                 , warp           >= 3.0+                 , front+    other-modules: Todo+    ghc-options:    -main-is ServantTodo -Wall+    default-language: Haskell2010++executable todo-yesod-example+  main-is:             YesodTodo.hs+  if !flag(examples)+    buildable: False+  else+    hs-source-dirs:      examples/todo+    build-depends: base+                 , front+                 , text+                 , mtl+                 , fay+                 , random+                 , yesod-core+                 , yesod-static+                 , yesod-websockets+                 , conduit+                 , aeson+                 , stm-lifted      >=0.1.1.0+                 , bytestring+  +    other-modules: Todo+    ghc-options:    -main-is YesodTodo -Wall+    default-language: Haskell2010

@@ -1,14 +1,16 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE NoImplicitPrelude  #-}+{-# LANGUAGE OverloadedStrings  #-} module Bridge where -import Prelude+import           Prelude -import Data.Data+import           Data.Data+import           Data.Text (Text) + -- | One specific and incomplete specifications of event-handlers geared -- towards their use with JS. data EventHandler a@@ -56,9 +58,79 @@              deriving (Functor, Typeable, Data) #endif +data In a = PingPong+  | Send (Action a)+  | AskEvents+  deriving (Data, Typeable)++data Out a = EmptyCmd+  | ExecuteClient ClientId (ClientTask a) ExecuteStrategy+  deriving (Data, Typeable)++data ExecuteStrategy =+  ExecuteAll | ExecuteExcept+  deriving (Data, Typeable, Eq)++data ClientTask a = ClientTask+  { executeRenderHtml :: [RenderHtml]+  , executeAction     :: [CallbackAction a]+  } deriving (Data, Typeable)++data RenderHtml = AttachText ElementId HtmlText+  | AttachDOM ElementId HtmlText deriving (Data, Typeable)+ data CallbackAction a = CallbackAction (EventHandler a) #ifdef FAY   deriving (Typeable, Data) #else   deriving (Typeable, Data)++instance Show a => Show (CallbackAction a) where+  show = show #endif++data Action a = Action ElementId ActionType a+#ifdef FAY+  deriving (Typeable, Data)+#else+  deriving (Show, Typeable, Data)+#endif++{-elementId :: Action a -> ElementId+elementId (Action e _ _) = e++actionType :: Action a -> ActionType+actionType (Action _ a _) = a++actionCmd :: Action a -> a+actionCmd (Action _ _ c) = c++updateAction :: Action a -> a -> Action a+updateAction (Action e a _) c = Action e a c-}++data ActionType = RecordAction | ObjectAction+#ifdef FAY+  deriving (Typeable, Data)+#else+  deriving (Show, Typeable, Data)+#endif++type ElementId = Text++type HtmlText = Text++type ObjectId = Int++type AttrId = Int++type ClientId = Int++type RowNumber = Int++type RecordValue = Text++-- | Pretty-printer for command expected from Client.+ppIncomingCommand :: In a -> Text+ppIncomingCommand AskEvents = "AskEvents"+ppIncomingCommand (Send _)  = "SendObjectAction"+ppIncomingCommand PingPong  = "PingPong"

@@ -0,0 +1,28 @@++module Web.Front where++import           Data.Text                 (Text)++import           Bridge+import           Text.Blaze.Front+import           Text.Blaze.Front.Renderer++import qualified Data.Text                 as T++-- | Generate message that will be pushed to client(s) based on underlying communication.+createTask+  :: Show a+  => Text -- ^ DOM Element Id.+  -> (t -> Markup a) -- ^ How to render state.+  -> t -- ^ State to render.+  -> ClientTask a -- ^ Message that will be pushed to client(s).+createTask eid renderer state = task+  where rhtml = AttachText eid (T.pack . renderHtml $ markup)+        markup = renderer state+        task = ClientTask+          { executeRenderHtml = [rhtml]+          , executeAction = registerEvents markup []+          }++emptyTask :: ClientTask a+emptyTask = ClientTask { executeRenderHtml = [], executeAction = [] }

@@ -0,0 +1,74 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Web.Front.Broadcast where++import           Bridge+import           Conduit+import           Control.Concurrent.Async+import           Control.Concurrent.STM.Lifted as STM+import           Control.Monad                 (forever)+import           Data.Aeson                    (Value, decode, toJSON)+import           Data.Aeson.Text+import qualified Data.ByteString.Lazy          as BL+import           Data.Data+import           Data.Text.Encoding            (encodeUtf8)+import           Data.Text.Lazy.Builder        (toLazyText)+import           Fay.Convert                   (showToFay)+import           Network.WebSockets            hiding (Headers)++-- | The common way how to use websocket 'Connection' obtained from 'Handler' via 'Conduit'.+-- 'interact' starts two concurrent processes.+-- First one is responsible for reading data from stream, decoding JSON message, executing custom business logic implemented by user and pushing the produced outgoing 'message' to 'TChan'.+-- The second process is constantly reading from 'TChan', encoding the given message and pushing it to all subscribers.+interact+  :: (CommandHandler cache model message, Data message, Data message2)+  => Connection+  -> TChan (Out (Action message))+  -> TChan (Out message2)+  -> cache model+  -> ClientId+  -> IO ()+interact stream in' out' tvar client = do+  race_+    (readLoop stream in' tvar client)+    (writeLoop stream out' client)++  where+    writeLoop+      :: Data message => Connection -> TChan (Out message) -> ClientId -> IO ()+    writeLoop _stream _out _client = forever $ liftIO $ do+      cmd <- atomically $ readTChan _out+      json <- pure $ toJSON $ showToFay cmd+      case cmd of+        EmptyCmd ->+          sendTextData _stream (toLazyText $ encodeToTextBuilder json)+        ExecuteClient cid task strategy -> do+          let sid = _client+          if sid == cid && strategy == ExecuteExcept+            then do+              json2 <- pure $ toJSON $ showToFay $+                ExecuteClient cid task ExecuteExcept+              sendTextData _stream (toLazyText $ encodeToTextBuilder json2)+            else do+              json2 <- pure $ toJSON $ showToFay $+                ExecuteClient cid task ExecuteAll+              sendTextData _stream (toLazyText $ encodeToTextBuilder json2)++    readLoop+      :: (CommandHandler cache model message, Data message)+      => Connection -> TChan (Out (Action message))+      -> cache model -> ClientId -> IO ()+    readLoop _stream _in _tvar _client = forever $ liftIO $ do+      data' <- receiveData _stream+      runConduit $ yield data' .| mapM_C (\cmdstr -> do+        case (decode $ BL.fromChunks [encodeUtf8 cmdstr] :: Maybe Value) of+          Nothing -> error "No JSON provided"+          Just cmd -> do+            liftIO $ putStrLn $ show cmd+            res <- onCommand cmd _tvar _client+            atomically $ writeTChan _in res)++-- | 'CommandHandler' class contains all business logic, i.e. how to change the given state ('cache model'), synchronize state for all online sessions and produce outgoing message with the 'Action'. 'Action' contains 'ClientId' to separate different sessions, 'ExecuteStrategy' to tell the 'Client' how to handle incoming message.+class Data cmd => CommandHandler cache model cmd where+  onCommand+    :: Value -> cache model -> ClientId -> IO (Out (Action cmd))+