Deadpan-DDP 0.3.0.2 → 0.4.1.0

raw patch · 9 files changed

+196/−177 lines, 9 filesdep +uuidPVP ok

version bump matches the API change (PVP)

Dependencies added: uuid

API changes (from Hackage documentation)

Files

• Deadpan-DDP.cabal +4/−4
• changelog.md +11/−0
• src/Data/EJson.hs +0/−2
• src/Data/EJson/EJson.hs +47/−0
• src/Data/EJson/Prism.hs +0/−59
• src/Main.hs +3/−4
• src/Web/DDP/Deadpan.hs +30/−38
• src/Web/DDP/Deadpan/Callbacks.hs +31/−1
• src/Web/DDP/Deadpan/DSL.hs +70/−69

@@ -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,

@@ -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

@@ -31,9 +31,7 @@ module Data.EJson (      module Data.EJson.EJson-  , module Data.EJson.Prism    ) where  import Data.EJson.EJson-import Data.EJson.Prism

@@ -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

@@ -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"

@@ -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")

@@ -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

@@ -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 

@@ -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)