Deadpan-DDP 0.6.0.1 → 0.7.0.0
raw patch · 10 files changed
+113/−89 lines, 10 filesdep −processdep ~QuickCheckdep ~base
Dependencies removed: process
Dependency ranges changed: QuickCheck, base
Files
- Deadpan-DDP.cabal +8/−15
- changelog.md +4/−0
- src/Data/EJson.hs +30/−17
- src/Main.hs +13/−6
- src/Web/DDP/Deadpan.hs +9/−8
- src/Web/DDP/Deadpan/Callbacks.hs +16/−17
- src/Web/DDP/Deadpan/DSL.hs +18/−14
- src/Web/DDP/Deadpan/Websockets.hs +9/−2
- test/DocTestTests.hs +6/−1
- test/QuickCheckTests.hs +0/−9
Deadpan-DDP.cabal view
@@ -1,5 +1,5 @@ name: Deadpan-DDP-version: 0.6.0.1+version: 0.7.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,8 +51,7 @@ build-depends: base >= 4 && < 5, websockets, network, text, unordered-containers, base64-bytestring, aeson, scientific, bytestring,- vector, lens,- network-uri, safe, mtl,+ vector, lens, network-uri, safe, mtl, containers, stm, transformers, time >= 1.4, random, hashable hs-source-dirs: src default-language: Haskell2010@@ -62,21 +61,15 @@ build-depends: base >= 4 && < 5, websockets, network, text, unordered-containers, base64-bytestring, aeson, scientific, bytestring,- vector, lens,- network-uri, safe, mtl,+ vector, lens, network-uri, safe, mtl, containers, stm, transformers, time >= 1.4, haskeline >= 0.7, random, hashable 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+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ main-is: test/DocTestTests.hs+ build-depends: base, doctest >= 0.8, QuickCheck+ default-language: Haskell2010
changelog.md view
@@ -1,5 +1,9 @@ # Deadpan-DDP Change Log +## 0.7.0.0++* Added newtype for IDs to prevent library mistakes+ ## 0.6.0.0 * Subscription capabilities have begun to be added
src/Data/EJson.hs view
@@ -37,17 +37,20 @@ module Data.EJson.EJson, module Data.EJson.EJson2Value, module Control.Lens,+ module Data.Monoid, matches,++ getInPath, putInPath, putInPath', modifyInPath, modifyInPath', removeFromPath, removeFromPath',+ pathToTraversal', makeMsg,- makeId, makeSubReady, makeNoSub, @@ -65,12 +68,17 @@ import Data.EJson.EJson import Data.EJson.EJson2Value+import Data.Monoid import Control.Lens import Control.Monad.State (execState) import Data.Text (Text()) import qualified Data.HashMap.Strict as HM +-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Control.Applicative+-- >>> import Test.QuickCheck -- | A function to check if all of the values in 'a' match values that exist in 'b'. -- Not the same as equality.@@ -101,6 +109,7 @@ 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.@@ -109,8 +118,6 @@ -- -- Examples: ----- >>> :set -XOverloadedStrings--- -- >>> putInPath ["a"] "b" (ejobject [("x","y")]) -- Right {"a":"b","x":"y"} --@@ -142,7 +149,6 @@ -- -- Example: ----- >>> :set -XOverloadedStrings -- >>> putInPath' ["a"] "b" "hello" -- "hello" --@@ -155,8 +161,6 @@ -- -- Examples: ----- >>> :set -XOverloadedStrings--- -- >>> modifyInPath [] (ejobject [("q","r")]) (ejobject [("x","y")]) -- Right {"q":"r","x":"y"} --@@ -186,8 +190,6 @@ -- -- Example: ----- >>> :set -XOverloadedStrings--- -- >>> modifyInPath' ["a", "b"] "c" (ejobject [("a","hello")]) -- {"a":"hello"} --@@ -204,8 +206,6 @@ -- -- Examples: ----- >>> :set -XOverloadedStrings--- -- >>> removeFromPath ["a"] (ejobject [("a","b"),("x","y")]) -- Right {"x":"y"} --@@ -222,6 +222,26 @@ of (Just _, Just r) -> Right r _ -> Left (concat ["Path ", show path, " not present in object ", show target]) +-- | getInPath fetches a value from an EJsonValue object at a point indicated by a path.+--+-- The path is a list of text values indicating successive object keys.+--+-- Examples:+--+-- >>> getInPath ["a"] (ejobject [("a","b"),("x","y")])+-- Just "b"+--+-- If you attempt to retrieve a value that does not exist,+-- then you will get Nothing.+--+-- Example:+--+-- >>> getInPath ["a","q","r"] (ejobject [("x","y")])+-- Nothing+--+getInPath :: [Text] -> EJsonValue -> Maybe EJsonValue+getInPath path target = Just target ^. pathToTraversal' path+ -- | Constructs a Traversal' along a path of EJObject keys. -- -- Both ends of the traversal are maybes in order to allow self-composition,@@ -236,8 +256,6 @@ -- -- Example: ----- >>> :set -XOverloadedStrings--- -- >>> removeFromPath' ["a","b"] (ejobject [("a", ejobject [("b","c")]), ("d","e")]) -- {"a":{},"d":"e"} --@@ -257,11 +275,6 @@ -- 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)] -- | Construct a matcher for subscription-ready based on ID. --
src/Main.hs view
@@ -11,7 +11,7 @@ import Data.Aeson import Data.Maybe import Control.Concurrent.Chan-import Data.EJson.Aeson -- TODO: Aeson instance should come with EJson import+import Data.EJson.Aeson() import qualified Data.ByteString.Lazy.Char8 as C8 import qualified System.Console.Haskeline as R @@ -45,16 +45,17 @@ 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+ Nothing -> liftIO $ writeChan c Nothing -- EOF / control-d+ Just "exit" -> liftIO $ writeChan c Nothing+ Just "help" -> liftIO instructions >> inOutLoop c+ Just "" -> inOutLoop c+ Just line -> 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"+ Nothing -> liftIO $ putStrLn "Invalid Message" getVersion :: [String] -> (Maybe (Maybe Version), [String]) getVersion ss = (extractVersion ss, deleteVersion ss)@@ -78,3 +79,9 @@ help = hPutStrLn stderr $ "Usage: deadpan [-h | --help] [ ( -v | --version ) " ++ "( " ++ intercalate " | " (map show $ reverse $ [minBound :: Version ..]) ++ " )" ++ " ] <URL>"++instructions :: IO ()+instructions = hPutStrLn stderr $ unlines [ "Input EJSON messages to send to the server."+ , "\"exit\" to exit."+ , "\"help\" for instructions."+ ]
src/Web/DDP/Deadpan.hs view
@@ -30,18 +30,22 @@ import Web.DDP.Deadpan.Websockets import Data.Maybe-import Control.Applicative import Control.Concurrent.STM import Control.Concurrent.Chan import Control.Monad.IO.Class+import Data.Sequence (empty) +-- $setup+-- >>> import Control.Applicative+-- >>> import Test.QuickCheck+ -- | Run a DeadpanApp against a set of connection parameters -- -- Only runs the app. Does not send connection request. Does not respond to ping! -- runBareClient :: Params -> DeadpanApp a -> IO a runBareClient params app = flip execURI params- $ \conn -> do appState <- newTVarIO $ AppState [] (ejobject []) conn+ $ \conn -> do appState <- newTVarIO $ AppState empty (ejobject []) conn runDeadpan app appState -- | Run a DeadpanApp after establishing a server conncetion@@ -68,7 +72,7 @@ -- | Automatically respond to server pings ---handlePings :: DeadpanApp Text+handlePings :: DeadpanApp GUID handlePings = setMsgHandler "ping" pingCallback -- | Log all incomming messages to STDOUT@@ -147,10 +151,7 @@ -- >>> _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 :: Traversal' (AppState a) EJsonValue subscriptions = collections . _EJObjectKey "subscription-data" . _Just @@ -178,6 +179,6 @@ -- -- TODO: The handler deletes itself when the session is set. ---setSession :: DeadpanApp Text+setSession :: DeadpanApp GUID setSession = setMsgHandler "connected" $ \e -> forOf_ (_EJObjectKey "session" . _Just) e (putInBase "session")
src/Web/DDP/Deadpan/Callbacks.hs view
@@ -26,10 +26,9 @@ -- Client Heartbeat pingCallback :: Callback-pingCallback ejv = do- let mpid = ejv ^. _EJObjectKey "id"- case mpid of Just pid -> sendMessage "pong" $ ejobject [("id", pid)]- Nothing -> sendMessage "pong" $ ejobject []+pingCallback = sendMessage "pong"+ . maybe (ejobject []) makeEJsonId+ . ejson2guid -- Client Data Subscriptions @@ -49,11 +48,11 @@ @ -}-clientDataSub :: Text -> Text -> [ EJsonValue ] -> DeadpanApp ()+clientDataSub :: GUID -> Text -> [ EJsonValue ] -> DeadpanApp () clientDataSub subid name params- = sendMessage "sub" $ ejobject [("name", ejstring name)- ,("params", ejarray params)- ,("id", ejstring subid)]+ = sendMessage "sub" $ makeEJsonId subid+ <> ejobject [ ("name", ejstring name)+ , ("params", ejarray params) ] -- | Activates a subscription with an auto-generated ID, returning the ID. --@@ -64,8 +63,8 @@ subscribeWait name params = do mv <- liftIO newEmptyMVar subId <- newID- handlerIdL <- setMatchHandler (makeNoSub subId) (handlerL mv)- handlerIdR <- setMatchHandler (makeSubReady subId) (handlerR mv)+ handlerIdL <- setMatchHandler (makeNoSub (getGuidText subId)) (handlerL mv)+ handlerIdR <- setMatchHandler (makeSubReady (getGuidText subId)) (handlerR mv) _ <- clientDataSub subId name params res <- liftIO $ readMVar mv @@ -89,11 +88,11 @@ id: string (the id passed to 'sub') @ -}-clientDataUnsub :: Text -> DeadpanApp ()-clientDataUnsub subid = sendMessage "unsub" $ ejobject [("id", ejstring subid)]+clientDataUnsub :: GUID -> DeadpanApp ()+clientDataUnsub subid = sendMessage "unsub" (makeEJsonId subid) -- | Synonym for `clientDataUnsub`-unsubscribe :: Text -> DeadpanApp ()+unsubscribe :: GUID -> DeadpanApp () unsubscribe = clientDataUnsub @@ -109,13 +108,13 @@ randomSeed: optional JSON value (an arbitrary client-determined seed for pseudo-random generators) @ -}-clientRPCMethod :: Text -> Maybe [EJsonValue] -> Text -> Maybe Text -> DeadpanApp ()+clientRPCMethod :: Text -> Maybe [EJsonValue] -> GUID -> Maybe Text -> DeadpanApp () clientRPCMethod method params rpcid seed = do- let msg = [("method", ejstring method), ("id", ejstring rpcid)]+ let msg = [("method", ejstring method)] &~ do forOf_ _Just params $ \v -> modify (("params", ejarray v):) forOf_ _Just seed $ \v -> modify (("seed", ejstring v):) - sendMessage "method" (ejobject msg)+ sendMessage "method" (makeEJsonId rpcid <> ejobject msg) -- | Like clientRPCMethod, except that it blocks, returning the response from the server. --@@ -125,7 +124,7 @@ rpcWait method params = do mv <- liftIO newEmptyMVar rpcId <- newID- handlerId <- setMatchHandler (makeId rpcId) (handler mv)+ handlerId <- setMatchHandler (makeEJsonId rpcId) (handler mv) _ <- clientRPCMethod method params rpcId Nothing res <- liftIO $ readMVar mv
src/Web/DDP/Deadpan/DSL.hs view
@@ -51,6 +51,7 @@ module Web.DDP.Deadpan.DSL ( module Web.DDP.Deadpan.DSL , module Data.EJson+ , module Web.DDP.Deadpan.GUID , Text , pack )@@ -65,8 +66,11 @@ import Control.Monad.Reader import Control.Lens import Data.Monoid+import Data.Foldable import Data.Text hiding (reverse, map) +import qualified Data.Sequence as Seq+ -- Internal Imports import Web.DDP.Deadpan.Comms@@ -80,11 +84,11 @@ -- -- _ident is a reference to the callback, not the expected message id. ---data LookupItem a = LI { _ident :: Text, _body :: a }+data LookupItem a = LI { _ident :: GUID, _body :: a } makeLenses ''LookupItem -type Lookup a = [ LookupItem a ]+type Lookup a = Seq.Seq ( LookupItem a ) data AppState cb = AppState { _callbackSet :: Lookup cb -- ^ Callbacks to match against by message@@ -138,36 +142,36 @@ -- IDs ---newID :: DeadpanApp Text-newID = liftIO newGuidText+newID :: DeadpanApp GUID+newID = liftIO newGuid -- Handlers addHandler :: LookupItem Callback -> DeadpanApp () addHandler i = modifyAppState foo- where foo x = x &~ callbackSet %= (i:)+ where foo x = x &~ callbackSet %= (|>i) -setHandler :: Text -> Callback -> DeadpanApp Text+setHandler :: GUID -> Callback -> DeadpanApp GUID setHandler guid cb = addHandler (LI guid cb) >> return guid onMatches :: EJsonValue -> Callback -> Callback onMatches val cb e = when (matches val e) (cb e) -setMatchHandler :: EJsonValue -> Callback -> DeadpanApp Text+setMatchHandler :: EJsonValue -> Callback -> DeadpanApp GUID setMatchHandler val cb = newID >>= flip setHandler (onMatches val cb) -setIdHandler :: Text -> Callback -> DeadpanApp Text-setIdHandler guid cb = newID >>= flip setHandler (onMatches (makeId guid) cb)+setIdHandler :: GUID -> Callback -> DeadpanApp GUID+setIdHandler guid cb = newID >>= flip setHandler (onMatches (makeEJsonId guid) cb) -setMsgHandler :: Text -> Callback -> DeadpanApp Text+setMsgHandler :: Text -> Callback -> DeadpanApp GUID setMsgHandler msg cb = newID >>= flip setHandler (onMatches (makeMsg msg) cb) -setCatchAllHandler :: Callback -> DeadpanApp Text+setCatchAllHandler :: Callback -> DeadpanApp GUID setCatchAllHandler cb = newID >>= flip setHandler cb -deleteHandlerID :: Text -> DeadpanApp ()+deleteHandlerID :: GUID -> DeadpanApp () deleteHandlerID k = modifyAppState $- over callbackSet (Prelude.filter ((/= k) . _ident))+ over callbackSet (Seq.filter ((/= k) . _ident)) modifyAppState :: (AppState Callback -> AppState Callback) -> DeadpanApp () modifyAppState f = DeadpanApp $ ask >>= liftIO . atomically . flip modifyTVar f@@ -240,4 +244,4 @@ -- respondToMessage :: Lookup Callback -> Maybe EJsonValue -> DeadpanApp () respondToMessage _ Nothing = return ()-respondToMessage cbSet (Just m) = forM_ cbSet $ \cb -> (fork . _body cb) m+respondToMessage cbSet (Just m) = for_ cbSet $ \cb -> (fork . _body cb) m
src/Web/DDP/Deadpan/Websockets.hs view
@@ -11,6 +11,7 @@ -} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} module Web.DDP.Deadpan.Websockets where @@ -18,9 +19,14 @@ import Safe (readDef) import Network.Socket (withSocketsDo) import Data.Text (Text())-import qualified Network.URI as U-import qualified Network.WebSockets as WS +import qualified Network.WebSockets as WS+import qualified "network-uri" Network.URI as U++-- $setup+-- >>> import Control.Applicative+-- >>> import Test.QuickCheck+ -- TODO: Use better types for these... type URL = String type Domain = String@@ -41,6 +47,7 @@ path = U.uriPath parsed return (domain, port, path) +-- | prop> prop_getURI_full prop_getURI_full, prop_getURI_missingPort :: Bool prop_getURI_full = getURI "http://localhost:1234/testing" == Right ("localhost", 1234, "/testing") prop_getURI_missingPort = getURI "http://localhost/testing" == Right ("localhost", 80, "/testing")
test/DocTestTests.hs view
@@ -3,4 +3,9 @@ import Test.DocTest -main = doctest ["-isrc", "src/Web/DDP/Deadpan.hs", "src/Data/EJson.hs"]+main = doctest [ "-isrc"+ , "src/Web/DDP/Deadpan.hs"+ , "src/Data/EJson.hs"+ , "src/Data/EJson/Props.hs"+ , "src/Web/DDP/Deadpan/Websockets.hs"+ ]
− test/QuickCheckTests.hs
@@ -1,9 +0,0 @@--module Main where--import Test.QuickCheck-import System.Process-import System.Exit--main :: IO ()-main = system "cd src && quickcheck Data/EJson/Props.hs" >>= exitWith