Deadpan-DDP 0.4.1.0 → 0.5.0.0
raw patch · 10 files changed
+306/−157 lines, 10 filesdep +QuickCheckdep +doctestdep +processdep −convertibledep ~base
Dependencies added: QuickCheck, doctest, process
Dependencies removed: convertible
Dependency ranges changed: base
Files
- Deadpan-DDP.cabal +15/−3
- src/Data/EJson.hs +89/−1
- src/Data/EJson/Aeson.hs +1/−0
- src/Data/EJson/EJson.hs +45/−79
- src/Main.hs +32/−7
- src/Web/DDP/Deadpan.hs +34/−3
- src/Web/DDP/Deadpan/Callbacks.hs +10/−26
- src/Web/DDP/Deadpan/DSL.hs +65/−38
- test/DocTestTests.hs +6/−0
- test/QuickCheckTests.hs +9/−0
Deadpan-DDP.cabal view
@@ -1,5 +1,5 @@ name: Deadpan-DDP-version: 0.4.1.0+version: 0.5.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. .@@ -51,7 +51,7 @@ build-depends: base >= 4 && < 5, websockets, network, uuid, text, unordered-containers, base64-bytestring, aeson, scientific, bytestring,- vector, convertible, lens,+ vector, lens, network-uri, safe, mtl, containers, stm, transformers, IfElse hs-source-dirs: src@@ -62,8 +62,20 @@ build-depends: base >= 4 && < 5, websockets, network, uuid, text, unordered-containers, base64-bytestring, aeson, scientific, bytestring,- vector, convertible, lens,+ vector, lens, network-uri, safe, mtl, containers, stm, transformers, IfElse hs-source-dirs: src default-language: Haskell2010++test-suite doctests+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ main-is: test/DocTestTests.hs+ build-depends: base, doctest >= 0.8++test-suite quickcheck+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ main-is: test/QuickCheckTests.hs+ build-depends: base, QuickCheck >= 2.0, process >= 1.0
src/Data/EJson.hs view
@@ -26,12 +26,100 @@ 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 #-}+ module Data.EJson ( - module Data.EJson.EJson+ module Data.EJson.EJson,+ module Data.EJson.EJson2Value,+ matches,+ makeMsg,+ makeId,+ isEJObject,+ isEJArray,+ isEJString,+ isEJNumber,+ isEJBool,+ isEJDate,+ isEJBinary,+ isEJUser,+ isEJNull ) where import Data.EJson.EJson+import Data.EJson.EJson2Value+import Control.Lens+import Data.HashMap.Strict+import Data.Text (Text())++++-- | 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 = ... }+--+-- is still considered as matching.+--+-- Matching is applied recursively.+--+-- Items that are not EJObjects are compared for equality directly.+--+matches :: EJsonValue -> EJsonValue -> Bool+matches a@(EJObject _) b@(EJObject _) = all pairMatches (kvs a)+ where++ kvs (EJObject h) = toList h+ kvs _ = []++ pairMatches (k,v) = case (b ^. _EJObjectKey k)+ of Just x -> matches v x+ Nothing -> False++matches a b = a == b++-- | Construct a simple message object with no data.+--+makeMsg :: Text -> EJsonValue+makeMsg key = ejobject [("msg", ejstring key)]++-- | Construct a simple object with only an ID.+--+makeId :: Text -> EJsonValue+makeId key = ejobject [("id", ejstring key)]++-- |+-- Examples:+--+-- >>> isEJObject EJNull+-- False++-- | Constructor tests...+isEJObject, isEJArray, isEJString, isEJNumber, isEJBool, isEJDate, isEJBinary, isEJUser, isEJNull :: EJsonValue -> Bool++isEJObject (EJObject _) = True+isEJObject _ = False+isEJArray (EJArray _) = True+isEJArray _ = False+isEJString (EJString _) = True+isEJString _ = False+isEJNumber (EJNumber _) = True+isEJNumber _ = False+isEJBool (EJBool _) = True+isEJBool _ = False+isEJDate (EJDate _) = True+isEJDate _ = False+isEJBinary (EJBinary _) = True+isEJBinary _ = False+isEJUser (EJUser _ _) = True+isEJUser _ = False+isEJNull EJNull = True+isEJNull _ = False
src/Data/EJson/Aeson.hs view
@@ -16,6 +16,7 @@ import Data.Aeson import Data.EJson.EJson+import Data.EJson.EJson2Value -- TODO: Consider implementing these translations directly, rather than passing through 'Value'.
src/Data/EJson/EJson.hs view
@@ -8,6 +8,9 @@ Functions are written to convert back and forth between `Data.EJson.EJsonValue` and `Data.Aeson.Value`. + The conversion functions from EJsonValue to Value are in a seperate+ module: "Data.EJson.EJson2Value".+ This has some negative impact on performance, but aids simplicity. -}@@ -26,7 +29,6 @@ -- Conversion functions , value2EJson- , ejson2value -- Smart Constructors , ejobject@@ -60,29 +62,24 @@ import Data.Scientific import Data.Text.Internal import Data.Text.Encoding-import Data.ByteString hiding (putStr)-import Data.Vector-import Data.Maybe-import Data.HashMap.Strict+import Data.ByteString hiding (putStr, map) import Data.ByteString.Base64+import Data.Maybe import Data.String import Control.Lens import Control.Applicative --- Time-import Data.Convertible-import System.Posix.Types (EpochTime)---- Display purposes-import qualified Data.ByteString.Lazy.Char8 as BC8+import qualified Data.Vector+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T data EJsonValue =- EJObject !(Data.HashMap.Strict.HashMap Text EJsonValue)+ EJObject !(HM.HashMap Text EJsonValue) | EJArray !(Data.Vector.Vector EJsonValue) | EJString !Text | EJNumber !Scientific | EJBool !Bool- | EJDate !EpochTime+ | EJDate !Scientific | EJBinary !ByteString | EJUser !Text !EJsonValue | EJNull@@ -119,13 +116,9 @@ -> f EJsonValue _EJAraryIndex i = _EJArray . ix i -instance Show EJsonValue- where- show = BC8.unpack . Data.Aeson.encode . ejson2value- instance IsString EJsonValue where- fromString = EJString . Data.Convertible.convert+ fromString = EJString . T.pack instance Monoid EJsonValue where@@ -150,34 +143,11 @@ negate (EJNumber a) = EJNumber (negate a) negate _ = error "don't negate non-numbers" -instance Convertible EpochTime Scientific- where- safeConvert e = Right (Data.Convertible.convert e)--ejson2value :: EJsonValue -> Value-ejson2value (EJObject h ) = Object (Data.HashMap.Strict.map ejson2value h)-ejson2value (EJArray v ) = Array (Data.Vector.map ejson2value v)-ejson2value (EJString t ) = String t-ejson2value (EJNumber n ) = Number n-ejson2value (EJBool b ) = Bool b-ejson2value (EJDate t ) = makeJsonDate t-ejson2value (EJBinary bs ) = String $ decodeUtf8 $ Data.ByteString.Base64.encode bs-ejson2value (EJUser t1 t2) = makeUser t1 t2-ejson2value (EJNull ) = Null--value2EJson :: Value -> EJsonValue-value2EJson (Object o) = escapeObject o-value2EJson (Array a) = EJArray $ Data.Vector.map value2EJson a-value2EJson (String s) = EJString s-value2EJson (Number n) = EJNumber n-value2EJson (Bool b) = EJBool b-value2EJson Null = EJNull- -- Smart Constructors {-# Inline ejobject #-} ejobject :: [(Text, EJsonValue)] -> EJsonValue-ejobject = EJObject . Data.HashMap.Strict.fromList+ejobject = EJObject . HM.fromList {-# Inline ejarray #-} ejarray :: [EJsonValue] -> EJsonValue@@ -196,7 +166,7 @@ ejbool = EJBool {-# Inline ejdate #-}-ejdate :: EpochTime -> EJsonValue+ejdate :: Scientific -> EJsonValue ejdate = EJDate {-# Inline ejbinary #-}@@ -212,16 +182,24 @@ ejnull = EJNull +-- Conversion++value2EJson :: Value -> EJsonValue+value2EJson (Object o) = escapeObject o+value2EJson (Array a) = EJArray $ Data.Vector.map value2EJson a+value2EJson (String s) = EJString s+value2EJson (Number n) = EJNumber n+value2EJson (Bool b) = EJBool b+value2EJson Null = EJNull++ -- Helpers simpleKey :: Text -> Object -> Maybe Value-simpleKey k = Data.HashMap.Strict.lookup k--integer2date :: Integer -> EpochTime-integer2date = Data.Convertible.convert+simpleKey k = HM.lookup k parseDate :: Value -> Maybe EJsonValue-parseDate (Number n) = Just $ EJDate $ integer2date $ round n+parseDate (Number n) = Just $ EJDate n parseDate _ = Nothing parseBinary :: Value -> Maybe EJsonValue@@ -236,37 +214,25 @@ parseEscaped (Object o) = Just $ simpleObj o parseEscaped _ = Nothing -isDate :: Int -> Object -> Maybe EJsonValue-isDate 1 o = parseDate =<< simpleKey "$date" o-isDate _ _ = Nothing-isBinary :: Int -> Object -> Maybe EJsonValue-isBinary 1 o = parseBinary =<< simpleKey "$binary" o-isBinary _ _ = Nothing-isUser :: Int -> Object -> Maybe EJsonValue-isUser 2 o = do t <- simpleKey "$type" o- v <- simpleKey "$value" o- parseUser t v-isUser _ _ = Nothing-isEscaped :: Int -> Object -> Maybe EJsonValue-isEscaped 1 o = parseEscaped =<< simpleKey "$escape" o-isEscaped _ _ = Nothing+getDate :: Int -> Object -> Maybe EJsonValue+getDate 1 o = parseDate =<< simpleKey "$date" o+getDate _ _ = Nothing+getBinary :: Int -> Object -> Maybe EJsonValue+getBinary 1 o = parseBinary =<< simpleKey "$binary" o+getBinary _ _ = Nothing+getUser :: Int -> Object -> Maybe EJsonValue+getUser 2 o = do t <- simpleKey "$type" o+ v <- simpleKey "$value" o+ parseUser t v+getUser _ _ = Nothing+getEscaped :: Int -> Object -> Maybe EJsonValue+getEscaped 1 o = parseEscaped =<< simpleKey "$escape" o+getEscaped _ _ = Nothing -simpleObj :: HashMap Text Value -> EJsonValue-simpleObj o = EJObject $ Data.HashMap.Strict.map value2EJson o+simpleObj :: HM.HashMap Text Value -> EJsonValue+simpleObj o = EJObject $ HM.map value2EJson o escapeObject :: Object -> EJsonValue-escapeObject o = fromMaybe (simpleObj o)- $ msum $ Prelude.map ($ o) [isDate l, isBinary l, isUser l, isEscaped l]- where- l = Data.HashMap.Strict.size o--makeJsonDate :: EpochTime -> Value-makeJsonDate t = Object- $ Data.HashMap.Strict.fromList- [ ("$date", Number $ Data.Convertible.convert t) ]--makeUser :: Text -> EJsonValue -> Value-makeUser t v = Object- $ Data.HashMap.Strict.fromList- [ ("$type" , String t)- , ("$value", ejson2value v)]+escapeObject o = fromMaybe (simpleObj o) $ msum+ $ map (`uncurry` (HM.size o, o))+ [getDate, getBinary, getUser, getEscaped]
src/Main.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE ViewPatterns #-}+ module Main (main) where +import Safe+import Data.List import System.IO import System.Exit import Web.DDP.Deadpan@@ -9,16 +13,37 @@ main = getArgs >>= go go :: [String] -> IO ()-go xs | hashelp xs = help-go [url] = void $ run $ getURI url-go _ = help >> exitFailure+go xs | hashelp xs = help+go (getVersion -> (v, [url])) = void $ run (getURI url) v+go _ = help >> exitFailure -run :: Either Error Params -> IO String-run (Left err ) = hPutStrLn stderr err >> exitFailure-run (Right params) = runPingClient params (logEverything >> liftIO getLine)+-- 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 (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)++getVersion :: [String] -> (Maybe (Maybe Version), [String])+getVersion ss = (extractVersion ss, deleteVersion ss)++extractVersion :: [String] -> Maybe (Maybe Version)+extractVersion ("-v" : x : _ ) = Just $ readMay x+extractVersion ("--version" : x : _ ) = Just $ readMay x+extractVersion ( _ : xs) = extractVersion xs+extractVersion _ = Nothing++deleteVersion :: [String] -> [String]+deleteVersion ("-v" : _ : xs) = deleteVersion xs+deleteVersion ("--version" : _ : xs) = deleteVersion xs+deleteVersion ( x : xs) = x : deleteVersion xs+deleteVersion xs = xs+ hashelp :: [String] -> Bool hashelp xs = any (flip elem xs) (words "-h --help") help :: IO ()-help = hPutStrLn stderr "Usage: deadpan [-h | --help] <URL>"+help = hPutStrLn stderr $ "Usage: deadpan [-h | --help] [ ( -v | --version ) "+ ++ "( " ++ intercalate " | " (map show $ reverse $ [minBound :: Version ..]) ++ " )"+ ++ " ] <URL>"
src/Web/DDP/Deadpan.hs view
@@ -24,6 +24,7 @@ ) where +import Control.Monad.IfElse (awhen) import Web.DDP.Deadpan.DSL import Web.DDP.Deadpan.Websockets import Web.DDP.Deadpan.Callbacks@@ -31,6 +32,7 @@ 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@@ -49,14 +51,24 @@ runConnectClient :: Params -> DeadpanApp a -> IO a runConnectClient params app = runBareClient params (fetchMessages >> connect >> app) +-- Same as runConnectClient above but allows specifying version+--+runConnectClientVersion :: Params -> Version -> DeadpanApp a -> IO a+runConnectClientVersion params v app = runBareClient params (fetchMessages >> connectVersion v >> app)+ -- | 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) +-- | Same as runPingClient above but allows specifying version+--+runPingClientVersion :: Params -> Version -> DeadpanApp a -> IO a+runPingClientVersion params v app = runConnectClientVersion params v (handlePings >> app)+ -- | Automatically respond to server pings ---handlePings :: DeadpanApp ()+handlePings :: DeadpanApp Text handlePings = setMsgHandler "ping" pingCallback -- | Log all incomming messages to STDOUT@@ -65,10 +77,12 @@ -- -- Returns the chan so that it can be used by other sections of the app. --+-- Alternatively just set LineBuffering on your output handle.+-- logEverything :: DeadpanApp (Chan String) logEverything = do pipe <- liftIO $ newChan- setCatchAllHandler (liftIO . writeChan pipe . show)- void $ fork $ liftIO $ getChanContents pipe >>= mapM_ putStrLn+ _ <- setCatchAllHandler (liftIO . writeChan pipe . show)+ _ <- fork $ liftIO $ getChanContents pipe >>= mapM_ putStrLn return pipe -- | A client that responds to server collection messages.@@ -77,3 +91,20 @@ -- collectiveClient :: IO (AppState Callback) collectiveClient = undefined++-- | A client that sets the session id if the server sends it+-- {"server_id":"83752cf1-a9bf-a15e-b06a-91f110383550"}+--+setServerID :: DeadpanApp ()+setServerID = undefined++putInBase :: Text -> EJsonValue -> DeadpanApp ()+putInBase 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"}+--+setSession :: DeadpanApp Text+setSession = setMsgHandler "connected" $+ \e -> awhen (e ^. _EJObjectKey "session")+ (putInBase "session")
src/Web/DDP/Deadpan/Callbacks.hs view
@@ -20,17 +20,7 @@ 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@@ -61,17 +51,14 @@ @ -}-clientDataSub :: Text -> Text -> Maybe [ EJsonValue ] -> DeadpanApp ()-clientDataSub subid name Nothing- = sendMessage "sub" $ ejobject [("name", ejstring name)- ,("id", ejstring subid)]-clientDataSub subid name (Just params)+clientDataSub :: Text -> Text -> [ EJsonValue ] -> DeadpanApp ()+clientDataSub subid name params = sendMessage "sub" $ ejobject [("name", ejstring name) ,("params", ejarray params) ,("id", ejstring subid)] -- | Synonym for `clientDataSub`-subscribe :: Text -> Text -> Maybe [ EJsonValue ] -> DeadpanApp ()+subscribe :: Text -> Text -> [ EJsonValue ] -> DeadpanApp () subscribe = clientDataSub {- |@@ -115,20 +102,17 @@ rpcWait :: Text -> Maybe [EJsonValue] -> DeadpanApp (Either EJsonValue EJsonValue) rpcWait method params = do uuid <- newID mv <- liftIO $ newEmptyMVar- setIdHandler uuid (handler mv uuid)+ _ <- setIdHandler uuid (handler mv uuid) clientRPCMethod method params uuid Nothing -- TODO: Should we use the seed?- val <- liftIO $ readMVar mv- return val+ liftIO $ readMVar mv where- handler mv uuid itm = do+ handler mv uuid itm = do awhen (itm ^. _EJObjectKey "error") $ \err -> do+ liftIO $ putMVar mv (Left err) - awhen (itm ^. _EJObjectKey "error") $ \err -> do- liftIO $ putMVar mv (Left err)- deleteHandlerID uuid+ awhen (itm ^. _EJObjectKey "result") $ \result -> do+ liftIO $ putMVar mv (Right result) - awhen (itm ^. _EJObjectKey "result") $ \result -> do- liftIO $ putMVar mv (Right result)- deleteHandlerID uuid+ deleteHandlerID uuid -- Server -->> Client
src/Web/DDP/Deadpan/DSL.hs view
@@ -65,7 +65,9 @@ import Control.Monad.Reader import Control.Lens import Data.Monoid-import Data.Text+import Data.Text hiding (reverse, map)+import Data.UUID.V4 (nextRandom)+import Data.UUID (toString) -- Internal Imports @@ -75,11 +77,11 @@ -- Let's do this! --- | 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.+-- | The LookupItem data-type is used to store a set of callbacks. ---data LookupItem a = LI { _ident :: Maybe Text, _messageType :: Maybe Text, _body :: a }+-- _ident is a reference to the callback, not the expected message id.+--+data LookupItem a = LI { _ident :: Text, _body :: a } makeLenses ''LookupItem @@ -118,6 +120,16 @@ makeLenses ''DeadpanApp +data Version = Vpre1 | Vpre2 | V1 deriving (Eq, Ord, Enum, Bounded, Read, Show)++version2string :: Version -> EJsonValue+version2string Vpre1 = ejstring "pre1"+version2string Vpre2 = ejstring "pre2"+version2string V1 = ejstring "1"++reverseVersions :: [EJsonValue]+reverseVersions = map version2string $ reverse [minBound ..]+ -- | The order of these args match that of runReaderT -- runDeadpan :: DeadpanApp a@@ -125,34 +137,51 @@ -> IO a runDeadpan app appState = runReaderT (_deadpanApp app) appState -setHandler :: LookupItem Callback -> DeadpanApp ()-setHandler i = modifyAppState foo+-- IDs+--+newID :: DeadpanApp Text+newID = do guid <- liftIO nextRandom+ let str = toString guid+ text = pack str+ return text++-- Handlers++addHandler :: LookupItem Callback -> DeadpanApp ()+addHandler i = modifyAppState foo where foo x = x &~ callbackSet %= (i:) -setIdHandler :: Text -> Callback -> DeadpanApp ()-setIdHandler myid cb = setHandler $ LI (Just myid) Nothing cb+setHandler :: Text -> Callback -> DeadpanApp Text+setHandler guid cb = addHandler (LI guid cb) >> return guid -setMsgHandler :: Text -> Callback -> DeadpanApp ()-setMsgHandler msg cb = setHandler $ LI Nothing (Just msg) cb+onMatchId :: Text -> Callback -> Callback+onMatchId guid cb e = when (matches (makeId guid) e) (cb e) -setCatchAllHandler :: Callback -> DeadpanApp ()-setCatchAllHandler cb = setHandler $ LI Nothing Nothing cb+setIdHandler :: Text -> Callback -> DeadpanApp Text+setIdHandler myid cb = setHandler myid (onMatchId myid cb) --- TODO: Use better names than foo and bar+onMatchMsg :: Text -> Callback -> Callback+onMatchMsg t cb e = when (matches (makeMsg t) e) (cb e)++setMsgHandler :: Text -> Callback -> DeadpanApp Text+setMsgHandler msg cb = newID >>= flip setHandler (onMatchMsg msg cb)++setCatchAllHandler :: Callback -> DeadpanApp Text+setCatchAllHandler cb = newID >>= flip setHandler cb+ deleteHandlerID :: Text -> DeadpanApp ()-deleteHandlerID k = modifyAppState foo- where foo x = x &~ callbackSet %= Prelude.filter bar- bar y = _ident y == Nothing || _ident y /= Just k+deleteHandlerID k = modifyAppState $+ over callbackSet (Prelude.filter ((/= k) . _ident)) modifyAppState :: (AppState Callback -> AppState Callback) -> DeadpanApp ()-modifyAppState f = DeadpanApp- $ do st <- ask- liftIO $ atomically $ do s <- readTVar st- writeTVar st (f s)+modifyAppState f = DeadpanApp $ ask >>= liftIO . atomically . flip modifyTVar f getAppState :: DeadpanApp (AppState Callback) getAppState = DeadpanApp $ ask >>= liftIO . atomically . readTVar +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.@@ -166,12 +195,15 @@ sendMessage :: Text -> EJsonValue -> DeadpanApp () sendMessage key m = sendData messageData where- messageData = ejobject [("msg", ejstring key)] `mappend` m+ messageData = makeMsg key `mappend` m +connectVersion :: Version -> DeadpanApp ()+connectVersion v = sendMessage "connect" $ ejobject [ ("version", version2string v)+ , ("support", ejarray $ reverseVersions) ]+ connect :: DeadpanApp ()-connect = sendMessage "connect" $- ejobject [ ("version", "1")- , ("support", ejarray ["1","pre2","pre1"]) ]+connect = sendMessage "connect" $ ejobject [ ("version", version2string V1)+ , ("support", ejarray $ reverseVersions) ] -- | Provides a way to fork a background thread running the app provided fork :: DeadpanApp a -> DeadpanApp ThreadId@@ -184,21 +216,16 @@ fork $ forever $ do message <- getServerMessage as <- getAppState- fork $ respondToMessage (_callbackSet as) message+ respondToMessage (_callbackSet as) message getServerMessage :: DeadpanApp (Maybe EJsonValue) getServerMessage = getAppState >>= liftIO . getEJ . _connection -(=?) :: Eq a => Maybe a -> Maybe a -> Bool-x@(Just _) =? y = x == y-_ =? _ = True-+-- | Loop through all callbacks+--+-- Each callback is responsible for discarding messages+-- that it doesn't care about...+-- 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)+respondToMessage _ Nothing = return ()+respondToMessage cbSet (Just m) = forM_ cbSet $ \cb -> (fork . _body cb) m
+ test/DocTestTests.hs view
@@ -0,0 +1,6 @@++module Main where++import Test.DocTest++main = doctest ["-isrc", "src/Web/DDP/Deadpan.hs", "src/Data/EJson.hs"]
+ test/QuickCheckTests.hs view
@@ -0,0 +1,9 @@++module Main where++import Test.QuickCheck+import System.Process+import System.Exit++main :: IO ()+main = system "cd src && quickcheck Data/EJson/Props.hs" >>= exitWith