diff --git a/Deadpan-DDP.cabal b/Deadpan-DDP.cabal --- a/Deadpan-DDP.cabal +++ b/Deadpan-DDP.cabal @@ -1,5 +1,5 @@ name: Deadpan-DDP -version: 0.3.0.2 +version: 0.4.1.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. . @@ -45,10 +45,10 @@ Extra-Source-Files: changelog.md library - exposed-modules: Data.EJson, Data.EJson.EJson, Data.EJson.Prism, Data.EJson.Aeson, + exposed-modules: Data.EJson, Data.EJson.EJson, Data.EJson.Aeson, Web.DDP.Deadpan, Web.DDP.Deadpan.Callbacks, Web.DDP.Deadpan.Comms, Web.DDP.Deadpan.DSL, Web.DDP.Deadpan.Websockets - build-depends: base >= 4 && < 5, websockets, network, + build-depends: base >= 4 && < 5, websockets, network, uuid, text, unordered-containers, base64-bytestring, aeson, scientific, bytestring, vector, convertible, lens, @@ -59,7 +59,7 @@ executable deadpan main-is: Main.hs - build-depends: base >= 4 && < 5, websockets, network, + build-depends: base >= 4 && < 5, websockets, network, uuid, text, unordered-containers, base64-bytestring, aeson, scientific, bytestring, vector, convertible, lens, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,16 @@ # Deadpan-DDP Change Log +## 0.4.1.0 + +* Fixed some bugs +* RPC responses now return an Either to indicate success or failure + +## 0.4.0.0 + +* Large refactor including API changes +* No longer require specifying app-state to run an app +* Added blocking RPCWait + ## 0.3.0.1 * Added further callback implementations diff --git a/src/Data/EJson.hs b/src/Data/EJson.hs --- a/src/Data/EJson.hs +++ b/src/Data/EJson.hs @@ -31,9 +31,7 @@ module Data.EJson ( module Data.EJson.EJson - , module Data.EJson.Prism ) where import Data.EJson.EJson -import Data.EJson.Prism diff --git a/src/Data/EJson/EJson.hs b/src/Data/EJson/EJson.hs --- a/src/Data/EJson/EJson.hs +++ b/src/Data/EJson/EJson.hs @@ -12,6 +12,7 @@ -} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -38,6 +39,19 @@ , ejuser , ejnull + -- Prisms + , _EJObject + , _EJObjectKey + , _EJObjectKeyString + , _EJArray + , _EJAraryIndex + , _EJString + , _EJNumber + , _EJBool + , _EJDate + , _EJBinary + , _EJUser + , _EJNull ) where import Data.Monoid @@ -52,6 +66,8 @@ import Data.HashMap.Strict import Data.ByteString.Base64 import Data.String +import Control.Lens +import Control.Applicative -- Time import Data.Convertible @@ -71,6 +87,37 @@ | EJUser !Text !EJsonValue | EJNull deriving (Eq) + +-- Instances follow! + +-- Prismo time! +-- http://adventuretime.wikia.com/wiki/Prismo + +makePrisms ''EJsonValue + +_EJObjectKey :: Applicative f + => Text + -> (Maybe EJsonValue -> f (Maybe EJsonValue)) + -> EJsonValue + -> f 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) + -> EJsonValue + -> f EJsonValue +_EJObjectKeyString k = _EJObject . at k . _Just . _EJString + +_EJAraryIndex :: Applicative f + => Int + -> (EJsonValue -> f EJsonValue) + -> EJsonValue + -> f EJsonValue +_EJAraryIndex i = _EJArray . ix i instance Show EJsonValue where diff --git a/src/Data/EJson/Prism.hs b/src/Data/EJson/Prism.hs deleted file mode 100644 --- a/src/Data/EJson/Prism.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-| - Description: Making EJsonValue Control.Lens compatible through `Control.Lens.Prism`s - - Making EJsonValue Control.Lens compatible through `Control.Lens.Prism`s - - Since EJsonValue is a sum-type, you need to take advantage of the `Control.Lens.Prism` - class provided by the Lens library if you wish to use it in a lens-compatible way. - - The set of instances is so-far incomplete. --} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.EJson.Prism - ( _EJObject - , _EJString - ) - where - --- External Imports - -import Data.Text -import Control.Lens -import Data.HashMap.Strict - --- Internal Imports - -import Data.EJson.EJson - - --- | _EJObject is a prism that allows access to the value represented by a --- lookup via a key in to an EJObject. --- --- This is constructed as a convenience so that you do not need to compose, --- or even have knowledge of the underlying HashMap implementaiton of --- EJObject. --- -_EJObject :: Text -> Prism' EJsonValue EJsonValue -_EJObject k = prism' (const EJNull) $ f -- TODO: Does const violate prism laws? - where f (EJObject h) = Data.HashMap.Strict.lookup k h - f _ = Nothing - -prop_ejopristest_null :: Bool -prop_ejopristest_null = EJNull ^? _EJObject "key" == Nothing - -prop_ejopristest_object :: Bool -prop_ejopristest_object = ejobject [("hello","world")] ^? _EJObject "hello" == Just "world" - --- | _EJString is a prism that points to the EJString constructor of --- the EJsonValue data-type. --- -_EJString :: Prism' EJsonValue Text -_EJString = prism' (const EJNull) $ f -- TODO: Does const violate prism laws? - where f (EJString s) = Just s - f _ = Nothing - -prop_ejspristest_string :: Bool -prop_ejspristest_string = ejstring "hello" ^? _EJString == Just "hello" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -10,13 +10,12 @@ go :: [String] -> IO () go xs | hashelp xs = help -go [url] = run $ getURI url +go [url] = void $ run $ getURI url go _ = help >> exitFailure -run :: Either Error Params -> IO () +run :: Either Error Params -> IO String run (Left err ) = hPutStrLn stderr err >> exitFailure -run (Right params) = do logger <- loggingClient - runClient logger params (liftIO $ void getLine) +run (Right params) = runPingClient params (logEverything >> liftIO getLine) hashelp :: [String] -> Bool hashelp xs = any (flip elem xs) (words "-h --help") diff --git a/src/Web/DDP/Deadpan.hs b/src/Web/DDP/Deadpan.hs --- a/src/Web/DDP/Deadpan.hs +++ b/src/Web/DDP/Deadpan.hs @@ -28,60 +28,52 @@ import Web.DDP.Deadpan.Websockets import Web.DDP.Deadpan.Callbacks -import Data.Map import Control.Concurrent.STM +import Control.Concurrent.Chan import Control.Monad import Control.Monad.IO.Class -- | Run a DeadpanApp against a set of connection parameters -- --- Automatically spawns a background thread to respond to server messages --- using the callback set provided in the App State. +-- Only runs the app. Does not send connection request. Does not respond to ping! -- -runClient :: AppState Callback -> Params -> DeadpanApp a -> IO a -runClient state params app = flip execURI params - $ \conn -> fmap fst $ runDeadpan (setup >> app) conn state +runBareClient :: Params -> DeadpanApp a -> IO a +runBareClient params app = flip execURI params + $ \conn -> do appState <- newTVarIO $ AppState [] (ejobject []) conn + runDeadpan app appState --- | Run a DeadpanApp against a set of connection parameters --- --- Does not register any callbacks to handle server messages automatically. --- This can be done with the `setup` function from "Web.DDP.Deadpan.DSL". +-- | Run a DeadpanApp after establishing a server conncetion -- --- Useful for running one-shot command-set applications... Not much else. +-- Does not respond to ping! -- -runUnhookedClient :: AppState Callback -> Params -> DeadpanApp a -> IO a -runUnhookedClient state params app = flip execURI params - $ \conn -> fmap fst $ runDeadpan (connect >> app) conn state - --- | A client that registers no initial callbacks --- Note: !!! This does not respond to ping, --- so you better perform your actions quickly! - -bareClient :: IO (AppState Callback) -bareClient = do - values <- newTVarIO (ejobject []) - return $ AppState (const $ return ()) Data.Map.empty values - - --- | A client that only responds to pings so that it can stay alive - -pingClient :: IO (AppState Callback) -pingClient = do - values <- newTVarIO (ejobject []) - return $ AppState (const $ return ()) (Data.Map.singleton "ping" pingCallback) values - +runConnectClient :: Params -> DeadpanApp a -> IO a +runConnectClient params app = runBareClient params (fetchMessages >> connect >> app) --- | A client that logs all server sent messages, responds to pings +-- | Run a DeadpanApp after registering a ping handler, then establishing a server conncetion. +-- +runPingClient :: Params -> DeadpanApp a -> IO a +runPingClient params app = runConnectClient params (handlePings >> app) -loggingClient :: IO (AppState Callback) -loggingClient = do - values <- newTVarIO (ejobject []) - return $ AppState (liftIO . print) (Data.Map.singleton "ping" pingCallback) values +-- | Automatically respond to server pings +-- +handlePings :: DeadpanApp () +handlePings = setMsgHandler "ping" pingCallback +-- | Log all incomming messages to STDOUT +-- +-- Passes all messages through a Chan in order to not intermingle output lines. +-- +-- Returns the chan so that it can be used by other sections of the app. +-- +logEverything :: DeadpanApp (Chan String) +logEverything = do pipe <- liftIO $ newChan + setCatchAllHandler (liftIO . writeChan pipe . show) + void $ fork $ liftIO $ getChanContents pipe >>= mapM_ putStrLn + return pipe -- | A client that responds to server collection messages. -- -- TODO: NOT YET IMPLEMENTED - +-- collectiveClient :: IO (AppState Callback) collectiveClient = undefined diff --git a/src/Web/DDP/Deadpan/Callbacks.hs b/src/Web/DDP/Deadpan/Callbacks.hs --- a/src/Web/DDP/Deadpan/Callbacks.hs +++ b/src/Web/DDP/Deadpan/Callbacks.hs @@ -16,10 +16,21 @@ module Web.DDP.Deadpan.Callbacks where import Web.DDP.Deadpan.DSL +import Control.Concurrent.MVar import Control.Monad.State import Control.Monad.IfElse (awhen) import Control.Lens +import Data.UUID.V4 (nextRandom) +import Data.UUID (toString) +-- IDs + +newID :: DeadpanApp Text +newID = do guid <- liftIO nextRandom + let str = toString guid + text = pack str + return text + -- Old Stuff... -- Client -->> Server @@ -28,7 +39,7 @@ pingCallback :: Callback pingCallback ejv = do - let mpid = ejv ^? _EJObject "id" + let mpid = ejv ^. _EJObjectKey "id" case mpid of Just pid -> sendMessage "pong" $ ejobject [("id", pid)] Nothing -> sendMessage "pong" $ ejobject [] @@ -99,6 +110,25 @@ sendMessage "method" (ejobject msg) +-- | Like clientRPCMethod, except that it blocks, returning the response from the server. +-- +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? + val <- liftIO $ readMVar mv + return val + where + handler mv uuid itm = do + + awhen (itm ^. _EJObjectKey "error") $ \err -> do + liftIO $ putMVar mv (Left err) + deleteHandlerID uuid + + awhen (itm ^. _EJObjectKey "result") $ \result -> do + liftIO $ putMVar mv (Right result) + deleteHandlerID uuid -- Server -->> Client diff --git a/src/Web/DDP/Deadpan/DSL.hs b/src/Web/DDP/Deadpan/DSL.hs --- a/src/Web/DDP/Deadpan/DSL.hs +++ b/src/Web/DDP/Deadpan/DSL.hs @@ -5,18 +5,7 @@ An EDSL designed to make writing deadpan applications easy! This DSL is a simple decoration of some application specific functions -arround an RWST monad instance. - -TODO: Check that this is still correct... - -@ - type deadpanapp a = Control.Monad.Rws.Rwst - network.websockets.connection - () - callbackset - io - a -@ +arround a ReaderT monad instance. A core cabal of functions are exported from this module which are then put to use in web.ddp.deadpan to create an expressive dsl for creating ddp applications. @@ -62,8 +51,8 @@ module Web.DDP.Deadpan.DSL ( module Web.DDP.Deadpan.DSL , module Data.EJson - , module Data.EJson.Prism , Text + , pack ) where @@ -73,27 +62,33 @@ import Control.Concurrent import Control.Applicative import Network.WebSockets -import Control.Monad.RWS +import Control.Monad.Reader import Control.Lens +import Data.Monoid import Data.Text -import Data.Map -- Internal Imports import Web.DDP.Deadpan.Comms -import Data.EJson.Prism import Data.EJson -- Let's do this! -type Lookup a = Data.Map.Map Text a +-- | The LookupItem data-type is used to store a set of callbacks +-- If ident, or messageType are set, then the callback will +-- only be called if these fields match. +-- +data LookupItem a = LI { _ident :: Maybe Text, _messageType :: Maybe Text, _body :: a } +makeLenses ''LookupItem + +type Lookup a = [ LookupItem a ] + data AppState cb = AppState - { _defaultCallback :: cb -- ^ The callback to run when no other callbacks match - , _callbackSet :: Lookup cb -- ^ Callbacks to match against by message - , _collections :: TVar EJsonValue -- ^ Shared data Expected to be an EJObject - -- , _localState :: ls -- ^ Thread-Local state -- TODO: Currently disabled + { _callbackSet :: Lookup cb -- ^ Callbacks to match against by message + , _collections :: EJsonValue -- ^ Shared data Expected to be an EJObject + , _connection :: Network.WebSockets.Connection -- ^ Network connection to server } makeLenses ''AppState @@ -101,12 +96,10 @@ type Callback = EJsonValue -> DeadpanApp () -- TODO: Allow any return type from callback newtype DeadpanApp a = DeadpanApp - { _deadpanApp :: Control.Monad.RWS.RWST - Network.WebSockets.Connection -- Reader - () -- Writer (ignore) - (AppState Callback) -- State - IO -- Parent Monad - a -- Result + { _deadpanApp :: ReaderT + (TVar (AppState Callback)) -- Reader + IO -- Parent Monad + a -- Result } instance Monad DeadpanApp where @@ -125,37 +118,47 @@ makeLenses ''DeadpanApp --- | The order of these args match that of runRWST +-- | The order of these args match that of runReaderT -- runDeadpan :: DeadpanApp a - -> Network.WebSockets.Connection - -> AppState Callback - -> IO (a, AppState Callback) -runDeadpan app conn appState = do - (a,s,_w) <- runRWST (_deadpanApp app) conn appState - return (a,s) + -> TVar (AppState Callback) + -> IO a +runDeadpan app appState = runReaderT (_deadpanApp app) appState --- TODO: Use a deadpan app in place of a callback -setHandler :: Text -> Callback -> DeadpanApp () -setHandler k cb = DeadpanApp $ callbackSet %= insert k cb +setHandler :: LookupItem Callback -> DeadpanApp () +setHandler i = modifyAppState foo + where foo x = x &~ callbackSet %= (i:) --- TODO: should I add getHandler/modifyHandler? +setIdHandler :: Text -> Callback -> DeadpanApp () +setIdHandler myid cb = setHandler $ LI (Just myid) Nothing cb -deleteHandler :: Text -> DeadpanApp () -deleteHandler k = DeadpanApp $ callbackSet %= delete k +setMsgHandler :: Text -> Callback -> DeadpanApp () +setMsgHandler msg cb = setHandler $ LI Nothing (Just msg) cb --- TODO: Once we have stabalised the definition of Callback --- we can make better use of the 'a' parameter... +setCatchAllHandler :: Callback -> DeadpanApp () +setCatchAllHandler cb = setHandler $ LI Nothing Nothing cb -setDefaultHandler :: Callback -> DeadpanApp () -setDefaultHandler cb = DeadpanApp $ defaultCallback .= cb +-- TODO: Use better names than foo and bar +deleteHandlerID :: Text -> DeadpanApp () +deleteHandlerID k = modifyAppState foo + where foo x = x &~ callbackSet %= Prelude.filter bar + bar y = _ident y == Nothing || _ident y /= Just k +modifyAppState :: (AppState Callback -> AppState Callback) -> DeadpanApp () +modifyAppState f = DeadpanApp + $ do st <- ask + liftIO $ atomically $ do s <- readTVar st + writeTVar st (f s) + +getAppState :: DeadpanApp (AppState Callback) +getAppState = DeadpanApp $ ask >>= liftIO . atomically . readTVar + -- | 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 = DeadpanApp $ ask >>= liftIO . flip sendEJ v +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 @@ -165,39 +168,37 @@ where messageData = ejobject [("msg", ejstring key)] `mappend` m --- TODO: Consider creating a 'get' instance to handle this... -getAppState :: DeadpanApp (AppState Callback) -getAppState = DeadpanApp $ get - connect :: DeadpanApp () connect = sendMessage "connect" $ ejobject [ ("version", "1") , ("support", ejarray ["1","pre2","pre1"]) ] -- | Provides a way to fork a background thread running the app provided --- TODO: Consider returning the thread-id -fork :: DeadpanApp a -> DeadpanApp () +fork :: DeadpanApp a -> DeadpanApp ThreadId fork app = do - conn <- DeadpanApp ask - appState <- DeadpanApp get - void $ liftIO $ forkIO $ void $ runDeadpan app conn appState + st <- DeadpanApp ask + liftIO $ forkIO $ void $ runDeadpan app st -setup :: DeadpanApp () -setup = do connect - fork $ - forever $ do as <- getAppState - message <- getServerMessage - respondToMessage (_callbackSet as) (_defaultCallback as) message +fetchMessages :: DeadpanApp () +fetchMessages = void $ + fork $ + forever $ do message <- getServerMessage + as <- getAppState + fork $ respondToMessage (_callbackSet as) message getServerMessage :: DeadpanApp (Maybe EJsonValue) -getServerMessage = DeadpanApp $ ask >>= liftIO . getEJ +getServerMessage = getAppState >>= liftIO . getEJ . _connection -respondToMessage :: Lookup Callback -> Callback -> Maybe EJsonValue -> DeadpanApp () -respondToMessage _ _ Nothing = return () -respondToMessage cbSet defCb (Just message) = do - let maybeMsgName = message ^? _EJObject "msg" . _EJString - maybeCallback = do msgName <- maybeMsgName - Data.Map.lookup msgName cbSet +(=?) :: Eq a => Maybe a -> Maybe a -> Bool +x@(Just _) =? y = x == y +_ =? _ = True - case maybeCallback of Just cb -> cb message - Nothing -> defCb message +respondToMessage :: Lookup Callback -> Maybe EJsonValue -> DeadpanApp () +respondToMessage _ Nothing = return () +respondToMessage cbSet (Just message) = do + let maybeMsgName = message ^? _EJObjectKeyString "msg" + maybeID = message ^? _EJObjectKeyString "id" + + forM_ cbSet $ \x -> do + when (_ident x =? maybeID && _messageType x =? maybeMsgName) + (_body x message)