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.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 diff --git a/src/Data/EJson.hs b/src/Data/EJson.hs --- a/src/Data/EJson.hs +++ b/src/Data/EJson.hs @@ -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 diff --git a/src/Data/EJson/Aeson.hs b/src/Data/EJson/Aeson.hs --- a/src/Data/EJson/Aeson.hs +++ b/src/Data/EJson/Aeson.hs @@ -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'. 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 @@ -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] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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] " +help = hPutStrLn stderr $ "Usage: deadpan [-h | --help] [ ( -v | --version ) " + ++ "( " ++ intercalate " | " (map show $ reverse $ [minBound :: Version ..]) ++ " )" + ++ " ] " 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 @@ -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") 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 @@ -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 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 @@ -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 diff --git a/test/DocTestTests.hs b/test/DocTestTests.hs new file mode 100644 --- /dev/null +++ b/test/DocTestTests.hs @@ -0,0 +1,6 @@ + +module Main where + +import Test.DocTest + +main = doctest ["-isrc", "src/Web/DDP/Deadpan.hs", "src/Data/EJson.hs"] diff --git a/test/QuickCheckTests.hs b/test/QuickCheckTests.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheckTests.hs @@ -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