Deadpan-DDP 0.5.0.0 → 0.6.0.0
raw patch · 8 files changed
+393/−69 lines, 8 filesdep +haskelinedep +timedep −IfElse
Dependencies added: haskeline, time
Dependencies removed: IfElse
Files
- Deadpan-DDP.cabal +4/−3
- changelog.md +7/−0
- src/Data/EJson.hs +183/−9
- src/Data/EJson/EJson.hs +10/−10
- src/Main.hs +34/−3
- src/Web/DDP/Deadpan.hs +88/−15
- src/Web/DDP/Deadpan/Callbacks.hs +40/−18
- src/Web/DDP/Deadpan/DSL.hs +27/−11
Deadpan-DDP.cabal view
@@ -1,5 +1,5 @@ name: Deadpan-DDP-version: 0.5.0.0+version: 0.6.0.0 synopsis: Write clients for Meteor's DDP Protocol description: The Deadpan-DDP project includes a debugging-tool, as well as a general purpose library. .@@ -53,7 +53,7 @@ aeson, scientific, bytestring, vector, lens, network-uri, safe, mtl,- containers, stm, transformers, IfElse+ containers, stm, transformers, time >= 1.4 hs-source-dirs: src default-language: Haskell2010 @@ -64,7 +64,8 @@ aeson, scientific, bytestring, vector, lens, network-uri, safe, mtl,- containers, stm, transformers, IfElse+ containers, stm, transformers, time >= 1.4,+ haskeline >= 0.7 hs-source-dirs: src default-language: Haskell2010
changelog.md view
@@ -1,5 +1,12 @@ # Deadpan-DDP Change Log +## 0.6.0.0++* Subscription capabilities have begun to be added+* Add Data+* Remove Data+* Wait on subscription+ ## 0.4.1.0 * Fixed some bugs
src/Data/EJson.hs view
@@ -23,22 +23,34 @@ The internals of EJson are defined in `Data.EJson.EJson`. - A Prism' instance is defined in `Data.EJson.Prism`.- Aeson instances are defined in `Data.EJson.Aeson`. This module tests examples and properties using DocTest. -} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoMonomorphismRestriction #-} module Data.EJson ( module Data.EJson.EJson, module Data.EJson.EJson2Value,+ module Control.Lens,+ matches,+ putInPath,+ putInPath',+ modifyInPath,+ modifyInPath',+ removeFromPath,+ removeFromPath',+ makeMsg, makeId,+ makeSubReady,+ makeNoSub,+ isEJObject, isEJArray, isEJString,@@ -54,18 +66,21 @@ import Data.EJson.EJson import Data.EJson.EJson2Value import Control.Lens-import Data.HashMap.Strict+import Control.Monad.State (execState) import Data.Text (Text()) +import qualified Data.HashMap.Strict as HM -- | A function to check if all of the values in 'a' match values that exist in 'b'. -- Not the same as equality. ----- { x = L <=> == { x = L--- , y = M <=> == , y = M--- , z = N <=> == , z = N--- } <=> ... , a = ... }+-- @+-- { x = L == { x = L+-- , y = M <=> == , y = M+-- , z = N == , z = N+-- } ... , a = ... }+-- @ -- -- is still considered as matching. --@@ -77,15 +92,161 @@ matches a@(EJObject _) b@(EJObject _) = all pairMatches (kvs a) where - kvs (EJObject h) = toList h+ kvs (EJObject h) = HM.toList h kvs _ = [] - pairMatches (k,v) = case (b ^. _EJObjectKey k)+ pairMatches (k,v) = case b ^. _EJObjectKey k of Just x -> matches v x Nothing -> False matches a b = a == b +-- | putInPath is a method for placing a value into an EJsonValue object at a point indicated by a path+-- The path is a list of text values indicating successive object keys.+-- This can't be done with simple lenses, as the nested obects may not exist.+-- If they do exist, then it is simply an update.+-- However, if they don't exist then EJObjects are created during the traversal.+--+-- Examples:+--+-- >>> :set -XOverloadedStrings+--+-- >>> putInPath ["a"] "b" (ejobject [("x","y")])+-- Right {"a":"b","x":"y"}+--+-- >>> putInPath ["a","q","r"] (ejobject [("s","t")]) (ejobject [("x","y")])+-- Right {"a":{"q":{"r":{"s":"t"}}},"x":"y"}+--+-- If you attempt to update a value as if it were an EJObject when in-fact it is something else,+-- then you will receive an Error.+--+-- Example:+--+-- >>> putInPath ["a", "b"] "c" (ejobject [("a","hello")])+-- Left "Value \"hello\" does not match path [\"b\"]."+--+putInPath :: [Text] -> EJsonValue -> EJsonValue -> Either String EJsonValue++putInPath [] payload _ = Right payload++putInPath (h:t) payload target@(EJObject _) =+ let l = _EJObjectKey h+ in case target ^. l+ of Nothing -> Right $ set l (Just (expandPayload t payload)) target+ Just v -> do r <- putInPath t payload v+ Right $ set l (Just r) target++putInPath path _ target = Left (concat ["Value ", show target, " does not match path ", show path, "."])++-- | A variatnt of putInPath that leaves the EJsonValue unchanged if the update is not sensible+--+-- Example:+--+-- >>> :set -XOverloadedStrings+-- >>> putInPath' ["a"] "b" "hello"+-- "hello"+--+putInPath' :: [Text] -> EJsonValue -> EJsonValue -> EJsonValue+putInPath' path payload target = case putInPath path payload target+ of Right x -> x+ Left _ -> target++-- | modifyInPath modifies values in an EJsonValue object at a point indicated by a path.+--+-- Examples:+--+-- >>> :set -XOverloadedStrings+--+-- >>> modifyInPath [] (ejobject [("q","r")]) (ejobject [("x","y")])+-- Right {"q":"r","x":"y"}+--+-- If you attempt to update a value as if it were an EJObject when in-fact it is something else,+-- then you will receive an Error.+--+-- Example:+--+-- >>> modifyInPath ["a", "b"] "c" (ejobject [("a","hello")])+-- Left "Path [\"a\",\"b\"] not present in object {\"a\":\"hello\"}"+--+-- >>> modifyInPath ["a", "b"] (ejobject [("a","hello")]) "c"+-- Left "Path [\"a\",\"b\"] not present in object \"c\""+--+modifyInPath :: [Text] -> EJsonValue -> EJsonValue -> Either String EJsonValue+modifyInPath path modifications target =+ case (Just target & pathToPrism path <<%~ fmap (simpleMerge modifications))+ of (Just _, Just r) -> Right r+ _ -> Left (concat ["Path ", show path, " not present in object ", show target])++simpleMerge :: EJsonValue -> EJsonValue -> EJsonValue+simpleMerge modifications = execState $ traverseOf_ _EJObject (mapM_ setPair . HM.toList) modifications+ where+ setPair (k,v) = _EJObjectKey k .= Just v++-- | A variatnt of modifyInPath that leaves the EJsonValue unchanged if the update is not sensible.+--+-- Example:+--+-- >>> :set -XOverloadedStrings+--+-- >>> modifyInPath' ["a", "b"] "c" (ejobject [("a","hello")])+-- {"a":"hello"}+--+-- >>> modifyInPath' ["a", "b"] (ejobject [("a","hello")]) "c"+-- "c"+--+modifyInPath' :: [Text] -> EJsonValue -> EJsonValue -> EJsonValue+modifyInPath' path modifications target =+ either (const target) id (modifyInPath path modifications target)++-- | removeFromPath removes values from an EJsonValue object at a point indicated by a path.+--+-- The path is a list of text values indicating successive object keys.+--+-- Examples:+--+-- >>> :set -XOverloadedStrings+--+-- >>> removeFromPath ["a"] (ejobject [("a","b"),("x","y")])+-- Right {"x":"y"}+--+-- If you attempt to update a value as if it were an EJObject when in-fact it is something else,+-- then you will receive an Error.+--+-- Example:+--+-- >>> removeFromPath ["a","q","r"] (ejobject [("x","y")])+-- Left "Path [\"a\",\"q\",\"r\"] not present in object {\"x\":\"y\"}"+--+removeFromPath :: [Text] -> EJsonValue -> Either String EJsonValue+removeFromPath path target = case (Just target & pathToPrism path <<.~ Nothing)+ of (Just _, Just r) -> Right r+ _ -> Left (concat ["Path ", show path, " not present in object ", show target])++pathToPrism :: [Text] -> Traversal' (Maybe EJsonValue) (Maybe EJsonValue)+pathToPrism path = foldl (.) id (map textToPrism path)++textToPrism :: Text -> Traversal' (Maybe EJsonValue) (Maybe EJsonValue)+textToPrism x = _Just . _EJObject . at x++-- | A variatnt of removeFromPath that leaves the EJsonValue unchanged if the update is not sensible+--+-- Example:+--+-- >>> :set -XOverloadedStrings+--+-- >>> removeFromPath' ["a","b"] (ejobject [("a", ejobject [("b","c")]), ("d","e")])+-- {"a":{},"d":"e"}+--+-- >>> removeFromPath' ["a"] "hello"+-- "hello"+--+removeFromPath' :: [Text] -> EJsonValue -> EJsonValue+removeFromPath' p v = either (const v) id (removeFromPath p v)+++expandPayload :: [Text] -> EJsonValue -> EJsonValue+expandPayload path payload = foldr ($) payload (map f path) where f x y = ejobject [(x,y)]+ -- | Construct a simple message object with no data. -- makeMsg :: Text -> EJsonValue@@ -95,6 +256,19 @@ -- makeId :: Text -> EJsonValue makeId key = ejobject [("id", ejstring key)]++-- | Construct a matcher for subscription-ready based on ID.+--+-- TODO: Allow for propper matcher behavior and abstraction a-la clojure's midje methods.+-- This is important as there could be multiple subscription ids listed here...+--+makeSubReady :: Text -> EJsonValue+makeSubReady key = ejobject [("msg","ready"), ("subs", ejarray [ejstring key])]++-- | Construct a matcher for subscription failure based on ID.+--+makeNoSub :: Text -> EJsonValue+makeNoSub key = ejobject [("msg","nosub"), ("id", ejstring key)] -- | -- Examples:
src/Data/EJson/EJson.hs view
@@ -15,7 +15,6 @@ -} -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}@@ -60,6 +59,8 @@ import Control.Monad import Data.Aeson import Data.Scientific+import Data.Time.Clock.POSIX+import Data.Time.Clock import Data.Text.Internal import Data.Text.Encoding import Data.ByteString hiding (putStr, map)@@ -79,7 +80,7 @@ | EJString !Text | EJNumber !Scientific | EJBool !Bool- | EJDate !Scientific+ | EJDate !UTCTime | EJBinary !ByteString | EJUser !Text !EJsonValue | EJNull@@ -92,16 +93,15 @@ makePrisms ''EJsonValue -_EJObjectKey :: Applicative f- => Text- -> (Maybe EJsonValue -> f (Maybe EJsonValue))- -> EJsonValue- -> f EJsonValue+-- Possibly access the value indicated by a key into a possible EJsonValue EJObject.+--+_EJObjectKey :: Text -> Traversal' EJsonValue (Maybe EJsonValue) _EJObjectKey k = _EJObject . at k -- | A helpful prism that looks up values of type EJ{"foo" : "bar", ...} -- with a Text key "foo" and returns Just "bar", or Nothing. -- Used frequently for checking message types and ids.+-- _EJObjectKeyString :: Applicative f => Text -> (Text -> f Text)@@ -167,7 +167,7 @@ {-# Inline ejdate #-} ejdate :: Scientific -> EJsonValue-ejdate = EJDate+ejdate = EJDate . posixSecondsToUTCTime . realToFrac {-# Inline ejbinary #-} ejbinary :: ByteString -> EJsonValue@@ -196,10 +196,10 @@ -- Helpers simpleKey :: Text -> Object -> Maybe Value-simpleKey k = HM.lookup k+simpleKey = HM.lookup parseDate :: Value -> Maybe EJsonValue-parseDate (Number n) = Just $ EJDate n+parseDate (Number n) = Just $ EJDate $ posixSecondsToUTCTime $ realToFrac n parseDate _ = Nothing parseBinary :: Value -> Maybe EJsonValue
src/Main.hs view
@@ -8,6 +8,12 @@ import System.Exit import Web.DDP.Deadpan import System.Environment+import Data.Aeson+import Data.Maybe+import Control.Concurrent.Chan+import Data.EJson.Aeson -- TODO: Aeson instance should come with EJson import+import qualified Data.ByteString.Lazy.Char8 as C8+import qualified System.Console.Haskeline as R main :: IO () main = getArgs >>= go@@ -19,11 +25,36 @@ -- TODO: No sane person would use this Maybe Maybe monstrosity, but aren't we all a little mad? -run :: Either Error Params -> Maybe (Maybe Version) -> IO String+run :: Either Error Params -> Maybe (Maybe Version) -> IO () run (Left err ) _ = hPutStrLn stderr err >> exitFailure run _ (Just Nothing) = hPutStrLn stderr "Incorrect version specified..." >> exitFailure-run (Right params) (Just (Just v)) = runPingClientVersion params v (logEverything >> liftIO getLine)-run (Right params) Nothing = runPingClient params (logEverything >> liftIO getLine)+run (Right params) (Just (Just v)) = runPingClientVersion params v (logEverything >> sendMessages)+run (Right params) Nothing = runPingClient params (logEverything >> sendMessages)++-- TODO: Allow a full DSL to be used rather than just messages?+--+sendMessages :: DeadpanApp ()+sendMessages = do+ c <- liftIO $ newChan+ let settings = R.defaultSettings { R.autoAddHistory = True }+ void $ fork $ liftIO $ R.runInputT settings (inOutLoop c)+ contents <- liftIO (getChanContents c)+ mapM_ sendPossibleMessage (catMaybes (takeWhile isJust contents))++inOutLoop :: Chan (Maybe String) -> R.InputT IO ()+inOutLoop c = do+ maybeLine <- R.getInputLine ""+ case maybeLine of+ Nothing -> liftIO $ writeChan c Nothing -- EOF / control-d+ Just ":exit" -> liftIO $ writeChan c Nothing+ Just line -> do liftIO $ writeChan c (Just line)+ inOutLoop c++sendPossibleMessage :: String -> DeadpanApp ()+sendPossibleMessage msgStr = do+ let decoded = decode $ C8.pack msgStr+ case decoded of Just m -> sendData m+ Nothing -> liftIO $ print "Invalid Message" getVersion :: [String] -> (Maybe (Maybe Version), [String]) getVersion ss = (extractVersion ss, deleteVersion ss)
src/Web/DDP/Deadpan.hs view
@@ -11,12 +11,11 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-} module Web.DDP.Deadpan ( module Web.DDP.Deadpan- , module Web.DDP.Deadpan.DSL- , module Web.DDP.Deadpan.Callbacks- , module Control.Monad+ , module ReExports , getURI , Error , Params@@ -24,15 +23,16 @@ ) where -import Control.Monad.IfElse (awhen)-import Web.DDP.Deadpan.DSL+import Web.DDP.Deadpan.DSL as ReExports+import Web.DDP.Deadpan.Callbacks as ReExports+import Control.Monad as ReExports+ import Web.DDP.Deadpan.Websockets-import Web.DDP.Deadpan.Callbacks +import Data.Maybe+import Control.Applicative import Control.Concurrent.STM import Control.Concurrent.Chan-import Control.Monad-import Control.Lens import Control.Monad.IO.Class -- | Run a DeadpanApp against a set of connection parameters@@ -80,31 +80,104 @@ -- Alternatively just set LineBuffering on your output handle. -- logEverything :: DeadpanApp (Chan String)-logEverything = do pipe <- liftIO $ newChan+logEverything = do pipe <- liftIO newChan _ <- setCatchAllHandler (liftIO . writeChan pipe . show) _ <- fork $ liftIO $ getChanContents pipe >>= mapM_ putStrLn return pipe +-- | A variant of log-everything returning a chan to recieve messages on+-- instead of STDOUT.+logEverythingVia :: DeadpanApp (Chan String)+logEverythingVia = do pipe <- liftIO newChan+ _ <- setCatchAllHandler (liftIO . writeChan pipe . show)+ return pipe+ -- | A client that responds to server collection messages. ----- TODO: NOT YET IMPLEMENTED+-- Warning: this overwrites the "subscription-data" key of the collections field of the AppState. ---collectiveClient :: IO (AppState Callback)-collectiveClient = undefined+collect :: DeadpanApp ()+collect = void $ setMsgHandler "added" dataAdded+ >> setMsgHandler "removed" dataRemoved+ >> setMsgHandler "changed" dataChanged +-- | An app to handle the addition of subscription data items...+--+-- For Example: {"collection":"lists","msg":"added","id":"F73xFyAuKrqsb2J3m","fields":{"incompleteCount":6,"name":"Favorite Scientists"}}+--+-- Not especially useful on its own. You would usually use `collect` instead.+--+dataAdded :: Callback+dataAdded m = fromMaybe (return ()) $ do+ collectionName <- m ^? _EJObjectKeyString "collection"+ itemId <- m ^? _EJObjectKeyString "id"+ fields <- m ^. _EJObjectKey "fields"+ return $ modifyAppState (over collections (putInPath' ["subscription-data", collectionName, itemId] fields))++-- | An app to handle the modification of subscription data items...+--+-- For Example: {"collection":"lists","msg":"changed","id":"TThFzYerrZaxmgjA7","fields":{"name":"List Aasdf"}}+--+-- Not especially useful on its own. You would usually use `collect` instead.+--+dataChanged :: Callback+dataChanged m = fromMaybe (return ()) $ do+ collectionName <- m ^? _EJObjectKeyString "collection"+ itemId <- m ^? _EJObjectKeyString "id"+ fields <- m ^. _EJObjectKey "fields"+ return $ modifyAppState (over collections (modifyInPath' ["subscription-data", collectionName, itemId] fields))++-- | An app to handle the removal of subscription data items...+--+-- For Example: {"collection":"lists","msg":"removed","id":"By8CtgWGvbZfJPFsd"}+--+-- Not especially useful on its own. You would usually use `collect` instead.+--+dataRemoved :: Callback+dataRemoved m = fromMaybe (return ()) $ do+ collectionName <- m ^? _EJObjectKeyString "collection"+ itemId <- m ^? _EJObjectKeyString "id"+ return $ modifyAppState (over collections (removeFromPath' ["subscription-data", collectionName, itemId]))++-- | A helper lens into the subscription data inside the collections section of the dynamic app state.+--+-- Example:+--+-- >>> :set -XOverloadedStrings+-- >>> _collections $ set (subscriptions . _EJObjectKey "songs") (Just ejnull) (AppState undefined ejnull undefined)+-- null+--+-- TODO: Make this a Simple Prism somehow...+-- subscriptions :: Simple Prism (AppState a) (Maybe EJsonValue)+--+subscriptions :: Applicative f => (EJsonValue -> f EJsonValue) -> AppState cb0 -> f (AppState cb0)+subscriptions = collections . _EJObjectKey "subscription-data" . _Just++ -- | A client that sets the session id if the server sends it -- {"server_id":"83752cf1-a9bf-a15e-b06a-91f110383550"} --+-- The handler deletes itself when the session is set.+-- setServerID :: DeadpanApp ()-setServerID = undefined+setServerID = do+ hid <- newID+ void $ setHandler hid+ $ \e -> forOf_ (_EJObjectKey "server_id" . _Just) e+ $ \x -> putInBase "server_id" x+ >> deleteHandlerID hid putInBase :: Text -> EJsonValue -> DeadpanApp () putInBase k v = modifyAppState $ set (collections . _EJObjectKey k) (Just v) +-- ensure :: Lens -> Default -> Modifier -> NewValue+-- ensure k v = modifyAppState $ set (collections . _EJObjectKey k) (Just v)+ -- | A client that sets the server_id if the server sends it -- {"msg":"connected","session":"T6gBRv5RpCTwKcMSW"} --+-- TODO: The handler deletes itself when the session is set.+-- setSession :: DeadpanApp Text setSession = setMsgHandler "connected" $- \e -> awhen (e ^. _EJObjectKey "session")- (putInBase "session")+ \e -> forOf_ (_EJObjectKey "session" . _Just) e (putInBase "session")
src/Web/DDP/Deadpan/Callbacks.hs view
@@ -18,8 +18,6 @@ import Web.DDP.Deadpan.DSL import Control.Concurrent.MVar import Control.Monad.State-import Control.Monad.IfElse (awhen)-import Control.Lens -- Old Stuff... @@ -57,10 +55,32 @@ ,("params", ejarray params) ,("id", ejstring subid)] --- | Synonym for `clientDataSub`-subscribe :: Text -> Text -> [ EJsonValue ] -> DeadpanApp ()-subscribe = clientDataSub+-- | Activates a subscription with an auto-generated ID, returning the ID.+--+subscribe :: Text -> [ EJsonValue ] -> DeadpanApp ()+subscribe name params = newID >>= \guid -> clientDataSub guid name params +subscribeWait :: Text -> [EJsonValue] -> DeadpanApp (Either EJsonValue EJsonValue)+subscribeWait name params = do+ mv <- liftIO newEmptyMVar+ subId <- newID+ handlerIdL <- setMatchHandler (makeNoSub subId) (handlerL mv)+ handlerIdR <- setMatchHandler (makeSubReady subId) (handlerR mv)+ _ <- clientDataSub subId name params+ res <- liftIO $ readMVar mv++ -- Note: This occurs after reading the MVar so it should be safe.+ deleteHandlerID handlerIdR+ deleteHandlerID handlerIdL+ return res++ where+ -- {"msg":"ready","subs":["849d1899-f3af-44b9-919c-7a1ca72c8857"]}+ handlerR mv itm = liftIO $ putMVar mv $ Right itm+ -- {"error":{...},"msg":"nosub","id":"af0a7ce1-3c37-40d7-8875-b8e3dd737765"}+ handlerL mv itm = forOf_ (_EJObjectKey "error" . _Just) itm $ liftIO . putMVar mv . Left++ {- | Unsubscribe from an existing subscription indicated by its ID. @@ -92,27 +112,29 @@ clientRPCMethod :: Text -> Maybe [EJsonValue] -> Text -> Maybe Text -> DeadpanApp () clientRPCMethod method params rpcid seed = do let msg = [("method", ejstring method), ("id", ejstring rpcid)]- &~ do awhen params $ \v -> modify (("params", ejarray v) :)- awhen seed $ \v -> modify (("seed", ejstring v) :)+ &~ do forOf_ _Just params $ \v -> modify (("params", ejarray v):)+ forOf_ _Just seed $ \v -> modify (("seed", ejstring v):) sendMessage "method" (ejobject msg) -- | Like clientRPCMethod, except that it blocks, returning the response from the server. --+-- TODO: Should we use the seed?+-- rpcWait :: Text -> Maybe [EJsonValue] -> DeadpanApp (Either EJsonValue EJsonValue)-rpcWait method params = do uuid <- newID- mv <- liftIO $ newEmptyMVar- _ <- setIdHandler uuid (handler mv uuid)- clientRPCMethod method params uuid Nothing -- TODO: Should we use the seed?- liftIO $ readMVar mv- where- handler mv uuid itm = do awhen (itm ^. _EJObjectKey "error") $ \err -> do- liftIO $ putMVar mv (Left err)+rpcWait method params = do+ mv <- liftIO newEmptyMVar+ rpcId <- newID+ handlerId <- setMatchHandler (makeId rpcId) (handler mv)+ _ <- clientRPCMethod method params rpcId Nothing+ res <- liftIO $ readMVar mv - awhen (itm ^. _EJObjectKey "result") $ \result -> do- liftIO $ putMVar mv (Right result)+ deleteHandlerID handlerId -- Note: This occurs after reading the MVar so it should be safe.+ return res - deleteHandlerID uuid+ where+ handler mv itm = do forOf_ (_EJObjectKey "error" . _Just) itm $ liftIO . putMVar mv . Left+ forOf_ (_EJObjectKey "result" . _Just) itm $ liftIO . putMVar mv . Right -- Server -->> Client
src/Web/DDP/Deadpan/DSL.hs view
@@ -135,7 +135,7 @@ runDeadpan :: DeadpanApp a -> TVar (AppState Callback) -> IO a-runDeadpan app appState = runReaderT (_deadpanApp app) appState+runDeadpan app = runReaderT (_deadpanApp app) -- IDs --@@ -154,17 +154,17 @@ setHandler :: Text -> Callback -> DeadpanApp Text setHandler guid cb = addHandler (LI guid cb) >> return guid -onMatchId :: Text -> Callback -> Callback-onMatchId guid cb e = when (matches (makeId guid) e) (cb e)+onMatches :: EJsonValue -> Callback -> Callback+onMatches val cb e = when (matches val e) (cb e) -setIdHandler :: Text -> Callback -> DeadpanApp Text-setIdHandler myid cb = setHandler myid (onMatchId myid cb)+setMatchHandler :: EJsonValue -> Callback -> DeadpanApp Text+setMatchHandler val cb = newID >>= flip setHandler (onMatches val cb) -onMatchMsg :: Text -> Callback -> Callback-onMatchMsg t cb e = when (matches (makeMsg t) e) (cb e)+setIdHandler :: Text -> Callback -> DeadpanApp Text+setIdHandler guid cb = newID >>= flip setHandler (onMatches (makeId guid) cb) setMsgHandler :: Text -> Callback -> DeadpanApp Text-setMsgHandler msg cb = newID >>= flip setHandler (onMatchMsg msg cb)+setMsgHandler msg cb = newID >>= flip setHandler (onMatches (makeMsg msg) cb) setCatchAllHandler :: Callback -> DeadpanApp Text setCatchAllHandler cb = newID >>= flip setHandler cb@@ -176,34 +176,50 @@ modifyAppState :: (AppState Callback -> AppState Callback) -> DeadpanApp () modifyAppState f = DeadpanApp $ ask >>= liftIO . atomically . flip modifyTVar f +-- | Get the raw app state. Reads the value out of the TVar container.+-- getAppState :: DeadpanApp (AppState Callback) getAppState = DeadpanApp $ ask >>= liftIO . atomically . readTVar +-- | Get the app state in conjunction with a Prism, allowing for more succing state access+--+getAppStateL :: Prism' (AppState Callback) x -> DeadpanApp (Maybe x)+getAppStateL l = DeadpanApp $ do+ v <- ask+ w <- liftIO $ atomically $ readTVar v+ return $ w ^? l+ getCollections :: DeadpanApp EJsonValue getCollections = fmap _collections getAppState -- | A low-level function intended to be able to send any arbitrary data to the server. -- Given that all messages to the server are intended to fit the "message" format, -- You should probably use `sendMessage` instead.--- TODO: Decide if this should perform the request in a seperate thread...+-- sendData :: EJsonValue -> DeadpanApp () sendData v = getAppState >>= liftIO . flip sendEJ v . _connection -- | Send a particular type of message (indicated by the key) to the server. -- This should be the primary means of [client -> server] communication by -- a client application.+-- sendMessage :: Text -> EJsonValue -> DeadpanApp () sendMessage key m = sendData messageData where messageData = makeMsg key `mappend` m +-- | Send a connection message to the server and specify the DDP API version+-- that you wish to use.+-- connectVersion :: Version -> DeadpanApp () connectVersion v = sendMessage "connect" $ ejobject [ ("version", version2string v)- , ("support", ejarray $ reverseVersions) ]+ , ("support", ejarray reverseVersions) ] +-- | Send a generic connection message to the server.+-- connect :: DeadpanApp () connect = sendMessage "connect" $ ejobject [ ("version", version2string V1)- , ("support", ejarray $ reverseVersions) ]+ , ("support", ejarray reverseVersions) ] -- | Provides a way to fork a background thread running the app provided fork :: DeadpanApp a -> DeadpanApp ThreadId