Deadpan-DDP 0.7.0.0 → 0.8.0.0
raw patch · 8 files changed
+171/−42 lines, 8 files
Files
- Deadpan-DDP.cabal +3/−3
- changelog.md +4/−0
- src/Data/EJson.hs +6/−24
- src/Data/EJson/EJson2Value.hs +47/−0
- src/Main.hs +3/−3
- src/Web/DDP/Deadpan.hs +9/−10
- src/Web/DDP/Deadpan/Callbacks.hs +2/−2
- src/Web/DDP/Deadpan/GUID.hs +97/−0
Deadpan-DDP.cabal view
@@ -1,5 +1,5 @@ name: Deadpan-DDP-version: 0.7.0.0+version: 0.8.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. .@@ -45,9 +45,9 @@ Extra-Source-Files: changelog.md library- exposed-modules: Data.EJson, Data.EJson.EJson, Data.EJson.Aeson,+ exposed-modules: Data.EJson, Data.EJson.EJson, Data.EJson.Aeson, Data.EJson.EJson2Value, Web.DDP.Deadpan, Web.DDP.Deadpan.Callbacks, Web.DDP.Deadpan.Comms,- Web.DDP.Deadpan.DSL, Web.DDP.Deadpan.Websockets+ Web.DDP.Deadpan.DSL, Web.DDP.Deadpan.Websockets, Web.DDP.Deadpan.GUID build-depends: base >= 4 && < 5, websockets, network, text, unordered-containers, base64-bytestring, aeson, scientific, bytestring,
changelog.md view
@@ -1,5 +1,9 @@ # Deadpan-DDP Change Log +## 0.8.0.0++* Made GUID newtype abstract to prevent abuse+ ## 0.7.0.0 * Added newtype for IDs to prevent library mistakes
src/Data/EJson.hs view
@@ -34,10 +34,7 @@ module Data.EJson ( - module Data.EJson.EJson,- module Data.EJson.EJson2Value,- module Control.Lens,- module Data.Monoid,+ module Exports, matches, @@ -51,8 +48,6 @@ pathToTraversal', makeMsg,- makeSubReady,- makeNoSub, isEJObject, isEJArray,@@ -66,10 +61,10 @@ ) where -import Data.EJson.EJson-import Data.EJson.EJson2Value-import Data.Monoid-import Control.Lens+import Data.EJson.EJson as Exports+import Data.EJson.EJson2Value as Exports+import Data.Monoid as Exports+import Control.Lens as Exports import Control.Monad.State (execState) import Data.Text (Text()) @@ -218,7 +213,7 @@ -- Left "Path [\"a\",\"q\",\"r\"] not present in object {\"x\":\"y\"}" -- removeFromPath :: [Text] -> EJsonValue -> Either String EJsonValue-removeFromPath path target = case (Just target & pathToTraversal' path <<.~ Nothing)+removeFromPath path target = case Just target & pathToTraversal' path <<.~ Nothing of (Just _, Just r) -> Right r _ -> Left (concat ["Path ", show path, " not present in object ", show target]) @@ -275,19 +270,6 @@ -- makeMsg :: Text -> EJsonValue makeMsg key = ejobject [("msg", ejstring key)]---- | Construct a matcher for subscription-ready based on ID.------ TODO: Allow for propper matcher behavior and abstraction a-la clojure's midje methods.--- This is important as there could be multiple subscription ids listed here...----makeSubReady :: Text -> EJsonValue-makeSubReady key = ejobject [("msg","ready"), ("subs", ejarray [ejstring key])]---- | Construct a matcher for subscription failure based on ID.----makeNoSub :: Text -> EJsonValue-makeNoSub key = ejobject [("msg","nosub"), ("id", ejstring key)] -- | -- Examples:
+ src/Data/EJson/EJson2Value.hs view
@@ -0,0 +1,47 @@++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- I'm defining the orphan++module Data.EJson.EJson2Value ( ejson2value ) where++import Data.Aeson+import Data.Text.Internal+import Data.Text.Encoding+import Data.Vector+import Data.HashMap.Strict+import Data.ByteString.Base64+import Data.Time.Clock.POSIX+import Data.Time.Clock++-- Display purposes+import qualified Data.ByteString.Lazy.Char8 as BC8++import Data.EJson.EJson++instance Show EJsonValue+ where+ show = BC8.unpack . Data.Aeson.encode . ejson2value++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++makeUser :: Text -> EJsonValue -> Value+makeUser t v = Object+ $ Data.HashMap.Strict.fromList+ [ ("$type" , String t)+ , ("$value", ejson2value v)]++makeJsonDate :: UTCTime -> Value+makeJsonDate t = Object+ $ Data.HashMap.Strict.fromList+ [ ("$date", Number t') ]+ where+ t' = realToFrac $ utcTimeToPOSIXSeconds t
src/Main.hs view
@@ -35,7 +35,7 @@ -- sendMessages :: DeadpanApp () sendMessages = do- c <- liftIO $ newChan+ c <- liftIO newChan let settings = R.defaultSettings { R.autoAddHistory = True } void $ fork $ liftIO $ R.runInputT settings (inOutLoop c) contents <- liftIO (getChanContents c)@@ -73,11 +73,11 @@ deleteVersion xs = xs hashelp :: [String] -> Bool-hashelp xs = any (flip elem xs) (words "-h --help")+hashelp xs = any (`elem` xs) (words "-h --help") help :: IO () help = hPutStrLn stderr $ "Usage: deadpan [-h | --help] [ ( -v | --version ) "- ++ "( " ++ intercalate " | " (map show $ reverse $ [minBound :: Version ..]) ++ " )"+ ++ "( " ++ intercalate " | " (map show $ reverse [minBound :: Version ..]) ++ " )" ++ " ] <URL>" instructions :: IO ()
src/Web/DDP/Deadpan.hs view
@@ -105,6 +105,13 @@ >> setMsgHandler "removed" dataRemoved >> setMsgHandler "changed" dataChanged +dataOver :: ([Text] -> EJsonValue -> EJsonValue -> EJsonValue) -> Callback+dataOver f m = fromMaybe (return ()) $ do+ collectionName <- m ^? _EJObjectKeyString "collection"+ itemId <- m ^? _EJObjectKeyString "id"+ fields <- m ^. _EJObjectKey "fields"+ return $ modifyAppState (over collections (f ["subscription-data", collectionName, itemId] fields))+ -- | An app to handle the addition of subscription data items... -- -- For Example: {"collection":"lists","msg":"added","id":"F73xFyAuKrqsb2J3m","fields":{"incompleteCount":6,"name":"Favorite Scientists"}}@@ -112,11 +119,7 @@ -- Not especially useful on its own. You would usually use `collect` instead. -- dataAdded :: Callback-dataAdded m = fromMaybe (return ()) $ do- collectionName <- m ^? _EJObjectKeyString "collection"- itemId <- m ^? _EJObjectKeyString "id"- fields <- m ^. _EJObjectKey "fields"- return $ modifyAppState (over collections (putInPath' ["subscription-data", collectionName, itemId] fields))+dataAdded = dataOver putInPath' -- | An app to handle the modification of subscription data items... --@@ -125,11 +128,7 @@ -- Not especially useful on its own. You would usually use `collect` instead. -- dataChanged :: Callback-dataChanged m = fromMaybe (return ()) $ do- collectionName <- m ^? _EJObjectKeyString "collection"- itemId <- m ^? _EJObjectKeyString "id"- fields <- m ^. _EJObjectKey "fields"- return $ modifyAppState (over collections (modifyInPath' ["subscription-data", collectionName, itemId] fields))+dataChanged = dataOver modifyInPath' -- | An app to handle the removal of subscription data items... --
src/Web/DDP/Deadpan/Callbacks.hs view
@@ -63,8 +63,8 @@ subscribeWait name params = do mv <- liftIO newEmptyMVar subId <- newID- handlerIdL <- setMatchHandler (makeNoSub (getGuidText subId)) (handlerL mv)- handlerIdR <- setMatchHandler (makeSubReady (getGuidText subId)) (handlerR mv)+ handlerIdL <- setMatchHandler (guid2NoSub subId) (handlerL mv)+ handlerIdR <- setMatchHandler (guid2SubReady subId) (handlerR mv) _ <- clientDataSub subId name params res <- liftIO $ readMVar mv
+ src/Web/DDP/Deadpan/GUID.hs view
@@ -0,0 +1,97 @@+{-|++Description: A small helper to generate GUIDs++A small helper to generate GUIDs.++Provides functions to generate simple GUIDs.++-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveGeneric #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+++module Web.DDP.Deadpan.GUID ( GUID() -- No export of constructors in order to protect generation of IDs+ , newGuid+ , hashTriple+ , newGuidInt+ , newGuidString+ , newGuidText+ , makeEJsonId+ , ejson2guid+ , guid2SubReady+ , guid2NoSub+ ) where++-- Internal Imports++import Data.EJson++-- External Imports++import System.Random+import System.CPUTime+import Data.Time+import Data.Text+import Data.Hashable+import GHC.Generics++instance Hashable DiffTime where+ hashWithSalt s = (hashWithSalt s :: Double -> Int) . realToFrac++deriving instance Generic Day+instance Hashable Day++deriving instance Generic UTCTime+instance Hashable UTCTime++newtype GUID = GUID {getGuidText :: Text} deriving (Eq,Ord,Generic,Hashable)++instance Show GUID where show = show . getGuidText+++hashTriple :: IO (Integer,UTCTime,Integer)+hashTriple = do+ cpu <- getCPUTime+ time <- getCurrentTime+ rand <- randomIO+ return (cpu,time,rand)++newGuidInt :: IO Int+newGuidInt = hash `fmap` hashTriple++newGuidString :: IO String+newGuidString = (show . hash) `fmap` hashTriple++newGuidText :: IO Text+newGuidText = pack `fmap` newGuidString++newGuid :: IO GUID+newGuid = GUID `fmap` newGuidText++makeEJsonId :: GUID -> EJsonValue+makeEJsonId key = ejobject [("id", ejstring (getGuidText key))]++ejson2guid :: EJsonValue -> Maybe GUID+ejson2guid v = fmap GUID $ v ^? _EJObjectKeyString "id"++-- | Construct a matcher for subscription-ready based on ID.+--+-- TODO: Allow for propper matcher behavior and abstraction a-la clojure's midje methods.+-- This is important as there could be multiple subscription ids listed here...+--+guid2SubReady :: GUID -> EJsonValue+guid2SubReady key = ejobject [("msg","ready"), ("subs", ejarray [ejstring (getGuidText key)])]++-- | Construct a matcher for subscription failure based on ID.+--+guid2NoSub :: GUID -> EJsonValue+guid2NoSub key = ejobject [("msg","nosub"), ("id", ejstring (getGuidText key))]