diff --git a/Network/JMacroRPC/Base.hs b/Network/JMacroRPC/Base.hs --- a/Network/JMacroRPC/Base.hs +++ b/Network/JMacroRPC/Base.hs @@ -15,38 +15,24 @@ import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) import Control.Applicative -import Control.Arrow((***)) import Control.Concurrent import Control.Monad.Trans import Data.Aeson import Data.Attoparsec.Lazy import Data.Attoparsec.Number -import Data.Char(toLower) import Data.Foldable(foldMap) import qualified Data.IntMap as IM import Data.Monoid import Data.List(find) -import Data.Text(unpack) import Data.Vector(toList) import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.Map as M import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Language.Javascript.JMacro --- Throat Clearing - -instance ToJExpr Value where - toJExpr Null = ValExpr $ JVar $ StrI "null" - toJExpr (Bool b) = ValExpr $ JVar $ StrI $ map toLower (show b) - toJExpr (Number n) = ValExpr $ JDouble $ realToFrac n - toJExpr (String s) = ValExpr $ JStr $ unpack s - toJExpr (Array vs) = ValExpr $ JList $ map toJExpr $ toList vs - toJExpr (Object obj) = ValExpr $ JHash $ M.fromList $ map (unpack *** toJExpr) $ HM.toList obj - -- | A JSON request is a list of values type JRequest = [Value] @@ -67,7 +53,7 @@ toJsonRPC_ :: a -> ([Value] -> m JResult) instance (ToJSON b) => ToJsonRPC (IO (Either String b)) IO where - toJsonRPC_ f = \ _ -> fmap (fmap toJSON) $ f + toJsonRPC_ f = \ _ -> fmap (fmap toJSON) $ f instance (FromJSON a, ToJsonRPC b m) => ToJsonRPC (a -> b) m where toJsonRPC_ f (x:xs) = case fromJSON x of @@ -77,7 +63,7 @@ -- | Takes a compatible function to a JsonRPC. toJsonRPC :: ToJsonRPC a m => String -> a -> JsonRPC m () -toJsonRPC nm f = JsonRPC nm $ \() -> toJsonRPC_ f +toJsonRPC nm f = JsonRPC nm $ \() -> toJsonRPC_ f -- | Takes a compatible function to a JsonRPC making use of state (i.e. a conversation). toJsonConvRPC :: ToJsonRPC a m => String -> (s -> a) -> JsonRPC m s @@ -91,7 +77,7 @@ instance FromJSON b => ToJsonRPCCall (IO (Either String b)) ((BL.ByteString -> IO (Either String BL.ByteString)) -> Value -> String -> IO (Either String b)) where toJsonRPCCall_ xs _ = \remoteCall ident method -> do - res <- remoteCall $ encode $ object + res <- remoteCall $ encode $ object [ (T.pack "params" , toJSON $ reverse xs), (T.pack "jsonrpc", toJSON "2.0"), @@ -99,15 +85,15 @@ (T.pack "id", ident) ] return $ either (Left . id) toVal res - where + where toVal bs = case eitherResult $ parse json bs of Left err -> Left err - Right v -> + Right v -> case v of - Object m -> - case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","result","id"] of - Just [String code, res, Number _] -> + Object m -> + case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","result","id"] of + Just [String code, res, Number _] -> if code /= T.pack "2.0" then Left "bad protocol version" else case fromJSON res of @@ -117,10 +103,10 @@ _ -> Left $ "bad return val" ++ show v instance (ToJSON a, ToJsonRPCCall b c) => ToJsonRPCCall (a -> b) (a -> c) where - toJsonRPCCall_ xs f = \x -> toJsonRPCCall_ (toJSON x : xs) (f x) + toJsonRPCCall_ xs f = \x -> toJsonRPCCall_ (toJSON x : xs) (f x) --- | Send a function on Jsonable values to a function of the same signature whose logic is invokable on a remote server. This function operates on the type of its argument. The body can remain undefined. +-- | Send a function on Jsonable values to a function of the same signature whose logic is invokable on a remote server. This function operates on the type of its argument. The body can remain undefined. toJsonRPCCall :: ToJsonRPCCall a b => a -> b toJsonRPCCall x = toJsonRPCCall_ [] x @@ -132,9 +118,10 @@ -- | JMacro Javascript stub to invoke json-rpc calls from web browsers. invokeRPCLib :: JStat -invokeRPCLib = - [$jmacro| +invokeRPCLib = + [jmacro| var !jmacro_rpc_id = 0; + var !serverLoc = window.location.href.split(/[?#]/)[0]; fun invokeJsonRPC serverLoc method args { var res; $.ajax({type : "POST", @@ -144,7 +131,7 @@ params: args, jsonrpc: "2.0", method: method, - id: jmacro_rpc_id + id: jmacro_rpc_id }, success : \d {res = d}, dataType: "json", @@ -153,7 +140,7 @@ if(res.result) { return res.result; } else { - alert (res.error + ""); + alert (method + ": " + res.error.message + ""); } } |] @@ -167,10 +154,10 @@ handleRpcs getS rpcs bs = encode <$> case eitherResult $ parse json bs of Left err -> return $ errToVal Nothing (-32700) err - Right v -> - case v of - Object m -> case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","method","params","id"] of - Just [String code, String meth, Array params, Number ident] -> + Right v -> + case v of + Object m -> case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","method","params","id"] of + Just [String code, String meth, Array params, Number ident] -> if code /= T.pack "2.0" then return $ errToVal (Just $ toInt ident) (-32600) "wrong protocol version -- server requires 2.0" else case find (\(JsonRPC n _) -> n == T.unpack meth) rpcs of @@ -180,16 +167,16 @@ return $ errToVal Nothing (-32602) $ "bad params passed, require jsonrpc, method, params, id" _ -> return $ errToVal Nothing (-32700) "not passed an object" - where + where toInt (I i) = fromIntegral i toInt (D d) = round d jresToVal :: Int -> JResult -> Value jresToVal ident jres = - object $ + object $ [(T.pack "jsonrpc", toJSON "2.0"), - (T.pack "id", toJSON ident)] ++ - case jres of + (T.pack "id", toJSON ident)] ++ + case jres of Right r -> [(T.pack "result", r)] Left e -> [(T.pack "error", eobj 0 e)] @@ -197,12 +184,12 @@ eobj ecode msg = object [(T.pack "code",toJSON ecode),(T.pack "message",toJSON msg)] errToVal :: Maybe Int -> Int -> String -> Value - errToVal mident ecode msg = object $ + errToVal mident ecode msg = object $ [(T.pack "jsonrpc", toJSON "2.0"), (T.pack "id", maybe Null toJSON mident), (T.pack "error", eobj ecode msg)] --- | Used for creating server backends. Yes, this type is confusing. But unless you are creating a server backend, you can ignore it. Takes a function to generate some time identifier, a function to cull page state, a rpc handler, a function for creating a single page, a function to initialize a page state, and a bunch of rpcs, and creates a pair of handler functions (one for POST and one for GET) such that individual clients first pull a page with an embedded ID, along with client-side rpc functions. Those functions in turn interact with state local to that invocation of a page when they make json-rpc requests to the server. The cull function is in IO so it has access to whatever notion of time it desires, including the opportunity to not run at all. +-- | Used for creating server backends. Yes, this type is confusing. But unless you are creating a server backend, you can ignore it. Takes a function to generate some time identifier, a function to cull page state, a rpc handler, a function for creating a single page, a function to initialize a page state, and a bunch of rpcs, and creates a pair of handler functions (one for POST and one for GET) such that individual clients first pull a page with an embedded ID, along with client-side rpc functions. Those functions in turn interact with state local to that invocation of a page when they make json-rpc requests to the server. The cull function is in IO so it has access to whatever notion of time it desires, including the opportunity to not run at all. Note that the POST page should be served from the same url as the get page, but with an additional "/jrpcs" directory guard. mkConversationPageGen :: (MonadIO m1, MonadIO m) => IO timestamp -> (IM.IntMap (timestamp,s) -> IO (IM.IntMap (timestamp,s))) @@ -220,30 +207,35 @@ t <- getStamp newMap <- cullMap $ IM.insert ident (t,res) m return (newMap, res) - Nothing -> do + Nothing -> do s <- emptyState t <- getStamp - return (IM.insert ident (t,s) m,s) + m' <- cullMap m + return (IM.insert ident (t,s) m',s) genJs = do i <- liftIO $ modifyMVar identSupply $ \is -> return (is+1,is) - return $ invokeRPCLib - `mappend` - [$jmacro| - var !serverLoc = window.location.href.split(/[?#]/)[0]; - jmacro_rpc_id = `(i)`; - |] - `mappend` - foldMap toDecl rpcs - toDecl (JsonRPC n _) = BlockStat [ - DeclStat (StrI n) Nothing, - AssignStat (ValExpr $ JVar $ StrI n) - [$jmacroE|\ { - var a = Array.prototype.slice.call(arguments); - return (invokeJsonRPC (serverLoc + "jrpcs") `(n)` a); - } - |] - ] + return $ invokeRPCLib + `mappend` + [jmacro| + jmacro_rpc_id = `(i)`; + |] + `mappend` + foldMap jsonRPCToDecl rpcs + return $ (rpcFun stateFun rpcs, pageFun =<< genJs) + +-- | Converts a json rpc to a javascript declaration of the appropriate function. +jsonRPCToDecl :: JsonRPC a m -> JStat +jsonRPCToDecl (JsonRPC n _) = + BlockStat [ + DeclStat (StrI n) Nothing, + AssignStat (ValExpr $ JVar $ StrI n) + [jmacroE|\ { + var a = Array.prototype.slice.call(arguments); + return (invokeJsonRPC (serverLoc + "jrpcs") `(n)` a); + } + |] + ] type JState a = MVar (Either String a) diff --git a/Network/JMacroRPC/Panels.hs b/Network/JMacroRPC/Panels.hs new file mode 100644 --- /dev/null +++ b/Network/JMacroRPC/Panels.hs @@ -0,0 +1,853 @@ +{-# LANGUAGE GADTs, QuasiQuotes, TupleSections, ScopedTypeVariables, NoMonomorphismRestriction, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-} +{- | +Module : Network.JMacroRPC.Panels +Copyright : (c) Gershom Bazerman, 2012 +License : BSD 3 Clause +Maintainer : gershomb@gmail.com +Stability : experimental + +The Panels library provides continuation-style compositional web +development with no scaling hassle. On the server side, Panels are +entirely stateless, storing no client-specific state. This also means +that requests can be sharded to multiple servers without worrying +about replication of large session objects (authentication choices are +another issue entirely). + +Code is written with a set of combinators over `Panel`s, +which package up display and behavior simultaneously. Panels, inspired +by FRP, can provide `Signal`s, which are sampleable, `Event`s, which are +discrete and can trigger updates, and `Sink`s which can be bound to +Signals (behaving similarly to FRP wormholes). Semantics, by virtue of +client-server interaction, are necessarily evented rather than +continuous. + +Panels, which are built using this library, can then be displayed using one of a number of servers as backends. New backends can be created with the `panelToPageGen` function. + +Example usage: + +> testPanel :: (Monad m, Functor m) => Panel m +> testPanel = para "This is an example" +> <> plainHTML Blaze.br +> <> inDiv [ +> select ("default",1::Int) [("another",2)] $ \ evt selSignal selPanel -> +> selPanel <> +> (onEvent evt $ +> withSample selSignal $ \ selChoice -> +> select (show selChoice, selChoice) +> [(show $ selChoice + 1, selChoice + 1)] $ \ _evt selSignal2 selPanel2 -> +> button "click me" $ \ buttonEvt buttonPanel -> +> onEvent buttonEvt $ +> withSample selSignal2 $ \ selChoice2 -> +> (selPanel2 <> buttonPanel <> plainHTML Blaze.br +> <> (para $ "you chose: " ++ show (selChoice, selChoice2)))) +> ] + +The above code displays two dropdown menus and a button. The first dropdown determines the contents of the second. On clicking the button, the text updates with choices from both the first and second dropdowns. + +See the source of `calcPanel` for an example of mixed client/server updates with more complicated stateful interaction. + +-} +module Network.JMacroRPC.Panels ( + -- * Base Types + JS, Hask, PanelPath, + Event, Signal, Sink, + + -- * The PState Monad Transformer + PanelState, PState, newIdent, descended, + + -- * Page Slices and Panels + PageSlice(..), Panel(..), + + -- * Base Type Combinators + pureSig, + zipSinks, + contramapJs, + + -- * Building Panels + plainHTML, + onHtml, + joinWith, + buildInput, + inDiv, + para, + mkTable, + + -- * Interacting with signals, sinks, and events + withSample, + sampleSigJs, + onEvent, + tellSink, + bindSigSink, + sampleIO, + bindEventIO, + + -- * Derived panels and inputs. + button, select, selectInput, textPane, newVar, + + -- * Running Panels + panelPrelude, + panelToPageGen, + + -- * Examples + calcPanel + +) +where +import Control.Monad.State +import Control.Arrow((***)) +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Attoparsec.ByteString.Lazy(parse,Result(..)) +import Data.Functor.Contravariant +import Data.Map(Map) +import Data.Set(Set) +import Data.Maybe +import Language.Javascript.JMacro +import Text.Blaze.Html5(Html) +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5 as H5 +import Text.Blaze.Html5((!),toValue) +import qualified Text.Blaze.Html5.Attributes as H +import Control.Applicative +import Data.Monoid +import Data.List(intercalate) +import Data.String +import Data.Aeson +import Data.Aeson.Parser +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as T +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.ByteString.Char8 as B +import qualified Text.Blaze.Html.Renderer.Pretty as P +import qualified Text.Blaze.Html.Renderer.Text as T +import Data.List.Split + +import Network.JMacroRPC.Base + +-- | Type tag for Sinks and Signals that can be run in pure JavaScript. +data JS +-- | Type tag for Sinks and Signals that require server-side interaction. +data Hask + +-- | Unique label for any given panel in a control structure. +type PanelPath = [Int] + +printPath :: PanelPath -> String +printPath = intercalate "_" . map show . reverse + +-- | Conceptually, an Event is something that can trigger an update. +-- We can join two events (which gives us "or" semantics), and we can +-- trigger on an event. That's it. +-- In reality, an event is composed of the panelpaths to it's sources. +data Event = Event [PanelPath] + +instance Monoid Event where + mempty = Event [] + mappend (Event x) (Event y) = Event (x <> y) + +-- This isn't a real functor because fmap id isn't always id. +-- Note that monad breaks inspectability of ids. + +-- | A Signal can contain information drawn from client-side inputs. Signals are tagged as JS, Hask, or parametric. A signal of type JS can be read from purely on the client side, with no round trip. A signal of type Hask forms an applicative functor, so we can build server-side values with complex computed behaviours. +-- Note that @Signal Hask@ actually bends the applicative functor laws in that @fmap id@ on a signal that can be calculated directly in JS can send it to a signal that cannot be. This is a flaw, and it will be fixed. +data Signal typ a where + PureSig :: a -> Signal typ a + OneSig :: FromJSON a => PanelPath -> Signal typ a + MultiSig :: Signal typ1 a -> Signal typ2 b -> ((a,b) -> c) -> Signal Hask c + +-- TODO, IO Signals? + +instance Functor (Signal Hask) where + fmap f (PureSig x) = PureSig $ f x + fmap f (OneSig p) = MultiSig (OneSig p) (PureSig ()) (f . fst) + fmap f (MultiSig x y g) = MultiSig x y (f . g) + +instance Applicative (Signal Hask) where + pure x = PureSig x + (PureSig f) <*> x = fmap f x + f <*> (PureSig y) = fmap ($ y) f + f <*> x = MultiSig f x (uncurry ($)) + +-- | Since only some Signals are applicative functors, pureSig provides a @pure@ operation over all Signals. +pureSig :: a -> Signal typ a +pureSig = PureSig + + +-- | Sinks likewise are tagged as JS, Hask, or parametric. A sink of type JS can be written to purely on the client side, with no round trip. A sink of type Hask is a contravariant functor. +data Sink typ m a where + ServerSink :: (a -> PState m [JStat]) -> Sink Hask m a + PureSink :: ToJExpr a => JExpr -> Sink typ m a + +liftSink :: Monad m => Sink typ m a -> Sink Hask m a +liftSink (PureSink js) = ServerSink $ \x -> return [ [jmacro|`(js)` `(x)`|] ] +liftSink (ServerSink f) = ServerSink f + +runSink :: Monad m => Sink typ m a -> a -> PState m [JStat] +runSink (ServerSink f) = f +runSink x@(PureSink _) = runSink (liftSink x) + +instance Monad m => Contravariant (Sink Hask m) where + contramap f (ServerSink g) = ServerSink (g . f) + contramap f x = contramap f (liftSink x) + +-- | A JavaScript funcion can be contravariantly mapped over a Sink JS +contramapJs :: ToJExpr a => JExpr -> Sink JS m b -> Sink JS m a +contramapJs f (PureSink g) = PureSink [jmacroE|\x -> `(g)` (`(f)` x)|] + +-- TODO zipsinks over JS sinks too -- use liftsink + +-- | We can zip sinks up to combine them. +zipSinks :: Monad m => Sink Hask m a -> Sink Hask m b -> Sink Hask m (a,b) +zipSinks (ServerSink f) (ServerSink g) = ServerSink (\(x,y) -> liftM2 (<>) (f x) (g y)) +zipSinks s t = zipSinks (liftSink s) (liftSink t) + + +extractIds :: Signal typ a -> [PanelPath] +extractIds (PureSig _) = [] +extractIds (OneSig p) = [p] +extractIds (MultiSig x y _) = extractIds x <> extractIds y + +-- TODO add req environment + maybe refactor the clean/hacked envs + +-- | A PanelState contains environment information used to render Panels. +data PanelState = PanelState { + ps_path :: PanelPath, + ps_env :: Map String BS.ByteString, -- including stale parentpaths + ps_env_clean :: Map String BS.ByteString, -- including only fresh parentpaths + ps_events :: Set String, + ps_listener :: Maybe (String, Map String BS.ByteString) --the variable and local env for it if we're in an update context + } deriving (Show) + +-- | The PState Monad Transformer provides access o the PanelState. +type PState m a = StateT PanelState m a + +readSignal :: (Functor m, Monad m) => Signal typ a -> PState m a +readSignal x = case x of + PureSig v -> return v + OneSig p -> mbParse p . M.lookup (printPath p) . ps_env <$> get + MultiSig sa sb f -> fmap f $ liftA2 (,) (readSignal sa) (readSignal sb) + where mbParse p Nothing = error $ "no value in env for: " ++ printPath p + mbParse _ (Just v) = case parse value v of + Done _ jv -> case fromJSON jv of + Success a -> a + -- This is an ad hoc case to fall back on string decoding. blah. + _ -> case fromJSON (String $ T.decodeUtf8 $ B.concat $ BS.toChunks v) of + Success a -> a + _ -> error $ "unable to parse: " ++ show v + + + _ -> case fromJSON (String $ T.decodeUtf8 $ B.concat $ BS.toChunks v) of + Success a -> a + _ -> error $ "unable to parse string: " ++ show v + +setEnv :: (Functor m, Monad m, ToJSON a) => PanelPath -> a -> PState m () +setEnv i x = modify (\ps -> ps {ps_env = go (ps_env ps)}) + where go = M.insert (printPath i) (encode x) + +incrPath :: PanelPath -> PanelPath +incrPath (x:xs) = x + 1 : xs +incrPath [] = [] + +-- | We can get a fresh identifier out of a panel state. +newIdent :: (Monad m, Functor m) => PState m PanelPath +newIdent = do + i <- ps_path <$> get + modify (\s -> s {ps_path = incrPath i}) + return i + +-- | And we can get an identifier out before descending into a "local" +-- environment whose identifiers don't affect the main supply. Hence if +-- a local environment alters its pattern of consumption, identifiers +-- in the outer environment will remain stable. +descended :: (Monad m, Functor m) => (PanelPath -> PState m a) -> PState m a +descended f = do + i <- ps_path <$> get + modify (\s -> s {ps_path = 0 : i}) + res <- f i + modify (\s -> s {ps_path = incrPath i}) + return res + +-- | A PageSlice is a pair of Html and JavaScript. When a Panel is rendered, +-- all JavaScript ends up joined together in the head of the page, and all HTML below it. PageSlices are naturally Monoidal, just as Html is. +data PageSlice = PS { + htmlP :: Html, + jsP :: [JStat] + } + +instance Monoid PageSlice where + mempty = PS mempty mempty + mappend (PS h j) (PS h' j') = PS (h <> h') (j <> j') + +-- | A Panel is the pair of an action to produce a PageSlice and +-- an action to produce a list of locations with updated PageSlices. +-- The former is used to draw the initial page, and the latter to +-- modify it in response to events. Panels are also naturally Monoidal. +data Panel m = Panel { + drawP :: PState m PageSlice, + updateP :: PState m [(PanelPath, PageSlice)] + } + +instance Monad m => Monoid (Panel m) where + mempty = Panel (return mempty) (return mempty) + mappend (Panel d u) (Panel d' u') = Panel (liftM2 (<>) d d') (liftM2 (<>) u u') + +runPanelDraw :: (Monad m, Functor m) => Map String BS.ByteString -> Set String -> Panel m -> m PageSlice +runPanelDraw m s p = drawP p `evalStateT` startState + where startState = PanelState [0] m m s Nothing + +runPanelUpdateSlice :: (Monad m, Functor m) => (String, Map String BS.ByteString) -> Map String BS.ByteString -> Set String -> Panel m -> m [(PanelPath,PageSlice)] +runPanelUpdateSlice (slice, parentData) m s p = updateP p `evalStateT` startState + where startState = PanelState [0] (M.union parentData m) m s (Just (slice, parentData)) + +runPanelUpdateMany :: (Monad m, Functor m) => Map String BS.ByteString -> Map String (Map String BS.ByteString) -> Set String -> Panel m -> m [(PanelPath,PageSlice)] +runPanelUpdateMany m listenerData s p = concat <$> mapM go (M.toList listenerData) + where go listenerPair = runPanelUpdateSlice listenerPair m s p + +-- | We can lift any Html into a Panel trivially. +plainHTML :: (Monad m, Functor m) => Html -> Panel m +plainHTML h = Panel (return $ PS h []) (return []) + +onHtmlPS :: (Html -> Html) -> PageSlice -> PageSlice +onHtmlPS f (PS h j) = PS (f h) j + +-- | Similarly, we can map over any Html inside a panel (although the behavior may be odd on panels with internal update semantics). +onHtml :: (Monad m, Functor m) => (Html -> Html) -> Panel m -> Panel m +onHtml f (Panel d u) = Panel (fmap (onHtmlPS f) d) u + +joinWithPS :: ([Html] -> Html) -> [PageSlice] -> PageSlice +joinWithPS f ps = PS (f $ map htmlP ps) (concatMap jsP ps) + +-- | Given a function to join Html sections, we can fuse a list of panels into a single pannel by lifting that function. +joinWith :: (Monad m, Functor m) => ([Html] -> Html) -> [Panel m] -> Panel m +joinWith f xs = Panel (joinWithPS f <$> mapM drawP xs) (concat <$> mapM updateP xs) + +-- | Given an arbitrary Signal, and a continuation accepting a value of the underlying type of the signal, yield a simple Panel. +withSample :: (FromJSON a, Monad m, Functor m) => Signal typ a -> (a -> Panel m) -> Panel m +withSample sig k = Panel onDraw onUpdate + where onDraw = descended $ \i -> setDependenciesSig (printPath i) (extractIds sig) <$> ((drawP . k <=< readSignal) sig) + + onUpdate = descended $ const $ (updateP . k <=< readSignal) sig + +setDependenciesSig :: String -> [PanelPath] -> PageSlice -> PageSlice +setDependenciesSig pathI depList (PS h j) = PS + ((H.div ! H.id (toValue pathI) ! H.name (toValue "inp")) h) + (map (\d -> [jmacro|signalDepends(`(pathI)`,`(printPath d)`);|]) depList ++ j) + +-- TODO, allow JS signals to not just be .val(), but have arbitrary "getter" actions. + +-- | Given a Signal JS, produce a JavaScript expression that samples the value of the signal. +sampleSigJs :: ToJSON a => Signal JS a -> JExpr +sampleSigJs (OneSig ip) = [jmacroE|$("#"+`(ip)`).val()|] +sampleSigJs (PureSig x) = [jmacroE|`(toJSON x)`|] + +-- | Given an Event, and a Panel, update the Panel each time the event fires. +onEvent :: (Monad m, Functor m) => Event -> Panel m -> Panel m +onEvent (Event depList) p = Panel onDraw onUpdate + where onDraw = descended $ \i -> do + let ip = printPath i + setDependenciesEvt ip <$> drawP p + + setDependenciesEvt pathI (PS h j) = PS + ((H.div ! H.id (toValue pathI) ! H.name (toValue "evt")) h) + (map (\d -> [jmacro|eventDepends(`(pathI)`,`(printPath d)`);|]) depList ++ j) + + onUpdate = descended $ \i -> do + let ip = printPath i + events <- ps_events <$> get + listener <- fmap fst . ps_listener <$> get + let shouldUpdate = case listener of + Just l -> l == ip + Nothing -> any (`S.member` events) (map printPath depList) + if shouldUpdate + then do + parentDeps <- fromMaybe M.empty . fmap snd . ps_listener <$> get + setCleanState + (\x -> [(i,x)]) . setDependenciesUpd parentDeps ip <$> drawP p + else updateP p + + setCleanState = modify (\ps -> ps {ps_env = ps_env_clean ps}) + + setDependenciesUpd parentData pathI (PS h j) = PS + ((H.div ! H.id (toValue pathI) ! H.name (toValue "evt")) h) + (map (\d -> [jmacro|eventDependsPD(`(pathI)`,`(printPath d)`,`(M.map BS.unpack $ parentData)`);|]) depList ++ j) + +-- TODO SWITCH FUNCTION + +-- | Feed a value to a Sink. +tellSink :: (Functor m, Monad m) => Sink typ m a -> a -> Panel m +tellSink i x = Panel (do + l <- ps_listener <$> get + case l of + -- we're updating + Just _ -> PS mempty <$> runSink i x + -- we're not + Nothing -> return mempty + ) + (return []) + + +-- | Given an event, a signal, and a sink, on each firing of the event, feed the sink the current sampled value of the signal. If the Signal and Sink are both in JS, this can happen entirely on the client side. +bindSigSink :: (Monad m, Functor m, FromJSON a, ToJSON a) => Event -> Signal typ1 a -> Sink typ2 m a -> Panel m +bindSigSink (Event depList) (PureSig a) (PureSink js) = Panel draw (newIdent >> return []) + where draw = newIdent >>= \i -> return $ PS mempty (map (\eid -> [jmacro|clientEventDepends `(printPath i)` `(printPath eid)` (\ -> `(js)` `(toJSON a)`);|]) depList) + +bindSigSink (Event depList) (OneSig sid) (PureSink js) = Panel draw (newIdent >> return []) + where draw = newIdent >>= \i -> return $ PS mempty (map (\eid -> [jmacro|clientEventDepends `(printPath i)` `(printPath eid)` (\ -> `(js)` $("#"+`(sid)`).val());|]) depList) + +bindSigSink ev sig sink = onEvent ev . withSample sig $ \i -> tellSink sink i + +-- | This is a general purpose function for constructing Panels that provide signals and events, and optionally sinks. It takes a function from an identifier path to an intial value of a signal, optional sinks into the signal, and a panel "controlling" the signal. From this it yields a continuation function from the event and signal associated wih the panel, the optional sinks, and the signal "control" panel to a new panel to the new panel iself. +-- Usage of this function is best understood by viewing the source of inputs built using it. +buildInput :: (FromJSON a, ToJSON a, Monad m, Functor m) => + (PanelPath -> (a, sinks, Panel m)) -- ^ given a path, construct a so-located panel with an intial value and possibly some Sinks. + -> (Event -> Signal typ a -> sinks -> Panel m -> Panel m) -- ^ given a so-constructed panel, event, and signal, declare what panel to produce. + -> Panel m -- ^ result panel +buildInput mkInput k = Panel onDraw onUpdate + where onDraw = newIdent >>= \i -> do + let (initial, inputs, control) = mkInput i + e = Event [i] + s = OneSig i + p = k e s inputs control + setEnv i initial + descended $ \ i' -> setDependenciesSig (printPath i') [i] <$> drawP p + onUpdate = newIdent >>= \i -> + let (_, inputs, control) = mkInput i + e = Event [i] + s = OneSig i + p = k e s inputs control + in descended $ const $ updateP p + +-- NB descending and setting dependencies here is pessimistic w/r/t dependencies. But to be 'exact' we need all deps to propigate up even if guarded by if and case statements -- this means not using real if and case statements. +-- Nonetheless we at least only deliver potential deps and not *all* deps in completely orthogonal areas. +-- Not pessimistic is just avoiding the use of descended and setDependencies + +-- | Takes an initial value and a continuation taking an event and the button itself, yields a panel. +button :: (Monad m, Functor m) => String -> (Event -> Panel m -> Panel m) -> Panel m +button txt k = buildInput mkButton kont + where kont e _s _i p = k e p + mkButton i = ( + (), + (), + Panel (return $ PS htmlBit jsBit) (return []) + ) + where htmlBit = H.button ! H.id (toValue ip) $ fromString txt + jsBit = [[jmacro|registerButton(`(ip)`);|]] + ip = printPath i + +-- | Takes an intial (label, value) pair, a list of pairs of labeled values, and a continuation, building a Panel with a dropdown selector. +select :: (Monad m, Functor m, ToJSON a, FromJSON a) => (String, a) -> [(String, a)] -> (Event -> Signal typ a -> Panel m -> Panel m) -> Panel m +select defOpt options k = buildInput mkSelect kont + where kont evt sig _sink p = k evt sig p + mkSelect i = ( + snd defOpt, + (), + Panel (return $ PS htmlBit jsBit) (return []) + ) + where htmlBit = H.select ! H.id (toValue ip) $ mconcat $ map mkOption (defOpt : options) + mkOption (n,v) = H.option ! H.value (toValue . BS.unpack $ encode v) $ (fromString n) + jsBit = [[jmacro|registerSelect(`(ip)`);|]] + ip = printPath i + + +--TODO freezeUpdates combinator. renders section fixed -- e.g. one requiring IO or whatever. + +--TODO rename to sampleIO + +-- | Perform an action in the underlying monad and feed the result to a panel. Synchronous. +-- Note that this action will occur on every update, even when guarded by an onEvent. +sampleIO :: (Monad m) => m a -> (a -> Panel m) -> Panel m +sampleIO act k = Panel onDraw onUpdate + where onDraw = drawP . k =<< lift act + onUpdate = updateP . k =<< lift act + +-- | Execute an IO action when triggered by an event. This action only occurs when the event fires. +-- @bindEventIO e act = onEvent e $ Panel (return mempty) (lift act >> return mempty)@ +bindEventIO :: (Monad m, Functor m) => Event -> m () -> Panel m +bindEventIO e act = onEvent e $ Panel (return mempty) (lift act >> return mempty) + + +-- | a wrapper around select that immediately samples from the yielded signal. @selectInput defOpt opts k = select defOpt opts $ \e sig p -> withSample sig $ \i -> k e i p@ + +selectInput :: (Monad m, Functor m, FromJSON a, ToJSON a) => (String, a) -> [(String,a)] -> (Event -> a -> Panel m -> Panel m) -> Panel m +selectInput defOpt opts k = select defOpt opts $ \e sig p -> withSample sig $ \i -> k e i p + + +-- TODO make letters more uniform for argument types + +-- | A basic text input box. This box provides a Sink as well as a Signal, so it's contents can be controlled from elsewhere in the Panel. +textPane :: (Monad m, Functor m) => String -> (Event -> Signal typ String -> Sink typ m String -> Panel m -> Panel m) -> Panel m +textPane initial kont = buildInput mkInput kont + where mkInput i = ( + initial, + input, + Panel (return $ PS htmlBit jsBit) (return []) + ) + where htmlBit = H.input ! H.id (toValue ip) ! H.value (toValue initial) + jsBit = [[jmacro|registerInput(`(ip)`);|]] + ip = printPath i + input = PureSink [jmacroE|\x -> $("#"+`(ip)`).val(x)|] + +-- | A hidden input Panel that can be used as a mutable store, akin to an IORef or MVar. +newVar :: (Monad m, Functor m, ToJSON a, FromJSON a, ToJExpr a) => a -> (Event -> Signal typ a -> Sink typ m a -> Panel m -> Panel m) -> Panel m +newVar initial kont = buildInput mkInput kont + where mkInput i = ( + initial, + input, + Panel (return $ PS htmlBit jsBit) (return []) + ) + where htmlBit = H.input ! H.hidden (toValue True) ! H.id (toValue ip) ! H.value (toValue . BS.unpack $ encode initial) + jsBit = [[jmacro|registerInput(`(ip)`);|]] + ip = printPath i + input = PureSink [jmacroE|\x -> $("#"+`(ip)`).val(JSON.stringify(x))|] + + +-- lifted html combinator toys + +-- | Put a bunch of panels into a single div element. +-- @inDiv = onHtml H.div . mconcat@ +inDiv :: (Monad m, Functor m) => [Panel m] -> Panel m +inDiv = onHtml H.div . mconcat + +-- | Put some text into a p element. +-- @para = plainHTML . H.p . fromString@ +para :: (Monad m, Functor m) => String -> Panel m +para = plainHTML . H.p . fromString + +-- | Align a list of panels into a table with rows of the specified width. +-- @mkTable n xs = onHtml H.table . mconcat . map row $ chunksOf n xs +-- where row ys = onHtml H.tr . mconcat $ map (onHtml H.td) ys@ +mkTable :: (Monad m, Functor m) => Int -> [Panel m] -> Panel m +mkTable n xs = onHtml H.table . mconcat . map row $ chunksOf n xs + where row ys = onHtml H.tr . mconcat $ map (onHtml H.td) ys + +-- | JavaScript code for the reactive runtime system. +panelPrelude :: JStat +panelPrelude = [jmacro| + + fun setInsert set val { set[val] = true; return set; } + + fun setInsertMany set newset { + for(var n in newset) { + set[n] = true; + } + return set; + } + + fun setDeleteMany set newset { + for(var n in newset) { + delete set[n]; + } + return set; + } + + fun nullSet set { + for(k in set) { + return false; + } + return true; + } + + fun setToList set { + var lst = []; + for(k in set) { + lst.push(k); + } + return lst; + } + + + fun insertMapSet ms k v { + if(typeof ms[k] == "undefined") { + ms[k] = {} + } + setInsert(ms[k],v); + return ms; + } + + fun insertMapMap ms k k1 v { + if(typeof ms[k] == "undefined") { + ms[k] = {} + } + ms[k][k1] = v; + return ms; + } + + + // Map IDPath (Set IDPath) + // :: Map Event DependentSections + var !eventToDepsMap = {}; + + // Map Section DataRequired + // signalMap :: Map IDPath (Set IDPath) + var !sectToSigsMap = {}; + + // Map IDPath (Set IDPath) + var !listenerToParentDataMap = {}; + + // Map IDPath (Map IDPath (() -> IO ())) + var !eventToClientDepsMap = {}; + + // IDPath -> Set IDPath + fun subsetIDMapFromPfx pfx mp { + var pfl = pfx.length; + var res = {}; + for (var idp in mp) { + if(idp.slice(0,pfl) == pfx) { + setInsertMany res mp[idp]; + } + } + return res; + } + + + // -- TODO we don't need to iterate over the whole mp, just parent keys. + // -- Given a path, if any prefix of the path matches a key + // -- then add the elements of that key. + // IDPath -> Set IDPath + fun parentsIDMapFromPfx pfx mp { + var res = {}; + for (var idp in mp) { + if(pfx.slice(0,idp.length) == idp) { + setInsertMany res mp[idp]; + } + } + return res; + } + + fun signalDepends listenerId signalId -> insertMapSet sectToSigsMap listenerId signalId; + + // -- Initial write, put fresh map + fun eventDepends listenerId eventID { + insertMapSet eventToDepsMap eventID listenerId; + var parentDeps = parentsIDMapFromPfx listenerId sectToSigsMap; + var parentMap = {}; + for(var p in parentDeps) { + parentMap[p] = $("#"+p).val(); + } + listenerToParentDataMap[listenerId] = parentMap; + } + + // -- Subsequent writes, put + fun eventDependsPD listenerId eventId parentData { + insertMapSet eventToDepsMap eventId listenerId; + listenerToParentDataMap[listenerId] = parentData; + } + + fun clientEventDepends listenerId eventId js { + insertMapMap eventToClientDepsMap eventId listenerId js; + } + + fun invalidateRegion(uid) { + var pfl = uid.length; + var subSects = {}; + setInsert subSects uid; + for(var sect in sectToSigsMap) { + if(sect.slice(0,pfl) == uid) { + setInsert subSects sect; + delete sectToSigsMap[sect]; + } + } + // -- it *should* be true that there are no listners that are not subs? If not, there's this + for(var sect in sectToSigsMap) { + setDeleteMany sectToSigsMap[sect] subSects; + } + // -- each uid + all subs no longer provide events + var subEvts = {}; + setInsert subEvts uid; + for(var evt in eventToDepsMap) { + if(evt.slice(0,pfl) == uid) { + setInsert subEvts evt; + delete eventToDepsMap[evt]; + } + } + // -- each uid + all subs can no longer be dependencies *of* events + for(var evt in eventToDepsMap) { + setDeleteMany eventToDepsMap[evt] subEvts; + } + + // -- each listener no longer needs its parent data + for(var listener in listenerToParentDataMap) { + if(listener.slice(0,pfl) == uid) { + delete listener listenerToParentDataMap; + } + } + + // -- each client listener goes away + for(var evt in eventToClientDepsMap) { + if(evt.slice(0,pfl) == uid) { + eventToClientDepsMap[evt] = {}; + } + for(var listener in eventToClientDepsMap[evt]) { + if(listener.slice(0,pfl) == uid) { + delete listener eventToClientDepsMap[evt]; + } + } + } + } + + fun executeUpdate(ups) { + for(var i in ups) { + var [uid,[upane,ujs]] = ups[i]; + + // -- Invalidate Deps + invalidateRegion(uid); + + // -- Insert new Html + $("#"+uid).html(upane); + // -- Perform new JS + eval(ujs); + } + } + + fun registerButton b -> $("#"+b).data("isButton",true); + fun registerSelect s -> $("#"+s).data("isSelect",true); + fun registerInput s -> $("#"+s).data("isTextInput",true); + + fun fireEvent uid { + console.log("fireevent",uid); + // -- A set of everything depending on the event. + var deps = eventToDepsMap[uid]; + var depsExist = false; + + // -- The set of data trails leading to each dep + var depDataMap = {}; + + // -- The set of everything that things depending on the event or their children need in order to generate. Also the things their parents may pull. + var sectData = {}; + for (var dep in deps) { + depsExist = true; + setInsertMany sectData (subsetIDMapFromPfx dep sectToSigsMap); + setInsertMany sectData (parentsIDMapFromPfx dep sectToSigsMap); + depDataMap[dep] = listenerToParentDataMap[dep]; + } + + // -- Clientside handlers + var clientDeps = eventToClientDepsMap[uid] == null ? {} : eventToClientDepsMap[uid]; + console.log("clientDeps",clientDeps); + for (var cdep in clientDeps) { + console.log("cdep",clientDeps[cdep]); + clientDeps[cdep](); + } + + var envMap = {}; + for(var s in sectData) { + envMap[s] = $("#"+s).val(); + } + + if(depsExist) { + executeUpdate (updateEvent(envMap,depDataMap,[uid])); + } + } + + fun handleButton e { + var tg = $(e.target); + if(tg.data("isButton")) { + fireEvent(tg.attr("id")); + } + } + $("html").on("click", "button", handleButton); + + fun handleSelect e { + var tg = $(e.target); + if(tg.data("isSelect")) { + fireEvent(tg.attr("id")); + } + } + $("html").on("change", "select", handleSelect); + + fun handleInput e { + var tg = $(e.target); + if(tg.data("isTextInput")) { + fireEvent(tg.attr("id")); + } + } + $("html").on("change", "input", handleInput); + + |] + + +type UpdateList = [(String, (String,String))] + +-- TODO NOW. fix other modules to use simplified panelToPageGen + +-- | General function used to create backends for different servers and frameworks. +panelToPageGen :: forall m resp. (Monad m, Functor m, ToJsonRPC (m (Either String UpdateList)) m) => + ([JsonRPC m ()] -> m resp) -- ^ A function which serves stateless JsonRPCs. + -> (T.Text -> m resp) -- ^ A function which renders Text to a server response. + -> String -- ^ A page title. + -> Panel m -- ^ The panel to server + -> (m resp, m resp) -- ^ Two page handlers -- one for handling updates (POSTs), and the second for rendering the initial page (GETs). +panelToPageGen serveRpcs returnResponse title p = (updateHandler, drawHandler) + where drawHandler = do + dp <- runPanelDraw M.empty S.empty $ p + returnResponse $ T.renderHtml $ H.html $ do + H.head $ do + H5.title (fromString title) + H.script ! H.src (toValue "https://ajax.googleapis.com/ajax/libs/jquery/1.8.1/jquery.min.js") $ mempty + H.script . fromString . show . renderJs $ invokeRPCLib `mappend` rpcDecls `mappend` panelPrelude + H.script . fromString . show . renderJs . wrapJQuery . jsP $ dp + H.body . htmlP $ dp + + wrapJQuery jm = [jmacroE|$(\ {`(jm)`;})|] + + updateHandler = serveRpcs allRPCs + + allRPCs = [updateRPC] + rpcDecls = mconcat $ map jsonRPCToDecl allRPCs + + updateFun :: Map String BS.ByteString -> Map String (Map String BS.ByteString) -> Set String -> m (Either String UpdateList) + updateFun envMap listenerData eventSet = do + slices <- runPanelUpdateMany envMap listenerData eventSet p + return $ Right $ map (printPath *** renderPS) $ slices + + renderPS ps = (P.renderHtml . htmlP $ ps, + show . renderJs . mconcat . jsP $ ps) + + updateRPC :: JsonRPC m () + updateRPC = toJsonRPC "updateEvent" $ \envMap depDataMap eventSet -> updateFun envMap depDataMap eventSet + + +-- TODO more interesting control with inputs, like a dial or something. + + +--TODO define function composition combinator + + +-- | Example panel that displays a calculator. +calcPanel :: (Monad m, Functor m) => Panel m +calcPanel = textPane "0" $ \_ displaysig displayInp displaypane -> + newVar "0" $ \_ storesig storeInp storepane -> + newVar "" $ \_ cmdstoresig cmdstoreInp cmdstorepane -> + let + trimJs = [jmacroE|\x {for(var i = 0; i `(trimJs)` (`(sampleSigJs displaysig)` + x)|] displayInp + numButton val = button val $ \ e b -> b <> bindSigSink e (pureSig val) addDisplayInp + opButton val = button val $ \ e b -> b <> bindSigSink e (pureSig val) cmdstoreInp + <> bindSigSink e displaysig storeInp + <> bindSigSink e (pureSig "0") displayInp + clearButton = button "c" $ \ e b -> b <> + bindSigSink e (pureSig "0") storeInp <> + bindSigSink e (pureSig "0") displayInp <> + bindSigSink e (pureSig "") cmdstoreInp + equalButton = button "=" $ \ e b -> b <> onEvent e + (withSample cmdstoresig $ \cmdstoreval -> + withSample displaysig $ \dispval -> + withSample storesig $ \storeval -> + let execOp op = tellSink displayInp (show $ (read storeval :: Int) `op` (read dispval :: Int)) + in case cmdstoreval of + "+" -> execOp (+) + "-" -> execOp (flip subtract) + "*" -> execOp (*) + "/" -> execOp (div) + _ -> mempty) + buttonPane = mkTable 3 $ map (numButton . show) ([(1::Int)..9] ++ [0]) ++ map opButton ["+","-","*","/"] ++ [equalButton,clearButton] + in + inDiv [displaypane <> storepane <> cmdstorepane, + buttonPane + ] + +--TODO arbitrary typeclass driven pane manipulation? + diff --git a/jmacro-rpc.cabal b/jmacro-rpc.cabal --- a/jmacro-rpc.cabal +++ b/jmacro-rpc.cabal @@ -1,5 +1,5 @@ Name: jmacro-rpc -Version: 0.1 +Version: 0.2 Homepage: http://patch-tag.com/r/gershomb/jmacro-rpc License: BSD3 License-file: LICENSE @@ -9,17 +9,16 @@ Build-type: Simple Cabal-version: >=1.6 -Synopsis: JSON-RPC clients and servers using JMacro. +Synopsis: JSON-RPC clients and servers using JMacro, and evented client-server FRP. -Description: Base jmacro-rpc package. Provides server-idependent functions. +Description: Base jmacro-rpc package. Provides server-independent functions. Library - Exposed-modules: Network.JMacroRPC.Base - -- , Network.JMacroRPC.Http - - Build-depends: base >= 4, base < 7, jmacro > 0.5, text > 0.11, containers >= 0.4, bytestring >= 0.9.1, vector >= 0.8, attoparsec > 0.10, aeson >= 0.6, mtl > 2, unordered-containers > 0.1.4 - --, network > 2, HTTP > 4000 - + Exposed-modules: Network.JMacroRPC.Base, + Network.JMacroRPC.Panels + + Build-depends: base >= 4, base < 7, jmacro > 0.6, text > 0.11, containers >= 0.4, bytestring >= 0.9.1, vector >= 0.8, attoparsec > 0.10, aeson >= 0.6, mtl > 2, unordered-containers > 0.1.4, split >= 0.2, blaze-html >= 0.4, contravariant >= 0.1 + ghc-options: -Wall source-repository head