packages feed

Deadpan-DDP (empty) → 0.2.0.0

raw patch · 13 files changed

+945/−0 lines, 13 filesdep +aesondep +basedep +base64-bytestringsetup-changed

Dependencies added: aeson, base, base64-bytestring, bytestring, containers, convertible, lens, mtl, network, network-uri, safe, scientific, stm, text, transformers, unordered-containers, vector, websockets

Files

+ Deadpan-DDP.cabal view
@@ -0,0 +1,66 @@+name:                Deadpan-DDP+version:             0.2.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.+                     .+                     <https://github.com/meteor/meteor/blob/devel/packages/ddp/DDP.md DDP> is the protocol that+                     <http://meteor.com Meteor> speaks between client and server.+                     .+                     The DDP tech-stack is: Websockets -> JSON -> EJson -> Collections -> Subscriptions + RPC.+                     .+                     In order to use the debugging tool, install this package and run `deadpan` for a usage+                     statement.+                     .+                     In order to use the library, simply import "Web.DDP.Deadpan".+                     .+                     The DSL monad is largely based around RPC calls and callbacks.+                     In order to write an application you would call+                     `Web.DDP.Deadpan.runClient` with+                     .+                     * An initial application state (this includes initial callbacks)+                     * A set of connection parameters+                     * A `Web.DDP.Deadpan.DSL.Deadpan` application+                     .+                     There are several callback-sets provided in "Web.DDP.Deadpan",+                     however, if you want to pick in a more granular fashion,+                     look inside "Web.DDP.Deadpan.Callbacks".+                     .+                     The connection parameters are the triple (Domain, Port, Path)...+                     .+                     For convenience the function getURI is provided to turn a URI+                     of the form <websocket:://localhost:3000/websocket>+                     into the triple (Right ("localhost", 3000, "websocket"))...+                     or an error (Left "error message").+                     .+                     Refer to the <https://github.com/sordina/Deadpan-DDP#deadpan-ddp README.md> on Github for more information.+homepage:            http://github.com/sordina/Deadpan-DDP+license:             MIT+license-file:        LICENSE+author:              Lyndon Maydwell+maintainer:          maydwell@gmail.com+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Data.EJson, Data.EJson.EJson, Data.EJson.Prism, 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,+                       text, unordered-containers, base64-bytestring,+                       aeson, scientific, bytestring,+                       vector, convertible, lens,+                       network-uri, safe, mtl,+                       containers, stm, transformers+  hs-source-dirs:      src+  default-language:    Haskell2010++executable deadpan+  main-is:             Main.hs+  build-depends:       base >= 4 && < 5, websockets, network,+                       text, unordered-containers, base64-bytestring,+                       aeson, scientific, bytestring,+                       vector, convertible, lens,+                       network-uri, safe, mtl,+                       containers, stm, transformers+  hs-source-dirs:      src+  default-language:    Haskell2010
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) <year> <copyright holders>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/EJson.hs view
@@ -0,0 +1,39 @@+{-|+  Description : Convert between Aeson values and EJson Extended JSON values++  The DDP protocol uses an extended JSON format called EJSON.+  This is embedded inside JSON, so that all JSON is valid EJSON,+  but with certain object structures representing the extended+  types:++  <https://github.com/meteor/meteor/blob/devel/packages/ddp/DDP.md>++  This module provides a pair of functions, `value2EJson` and `ejson2value`+  that convert back and forth between these datatypes. It also provides the+  `EJsonValue` datatype itself.++  Currently there is no implementation of the usual Aeson conversion classes,+  but this may change in the future.++  There are several smart-constructors made available to construct instances+  of EJsonValue more easily. These match the constructors exactly, except for+  substituting lists for vectors, etc... These definitions are inlined.++  EJson functionality is intended to be used simply by importing `Data.EJson`.++  The internals of EJson are defined in `Data.EJson.EJson`.++  A Prism' instance is defined in `Data.EJson.Prism`.++  Aeson instances are defined in `Data.EJson.Aeson`.+-}++module Data.EJson (++    module Data.EJson.EJson+  , module Data.EJson.Prism++  ) where++import Data.EJson.EJson+import Data.EJson.Prism
+ src/Data/EJson/Aeson.hs view
@@ -0,0 +1,32 @@++{-|++  Description : Aeson instances for EJsonValue++  Piggybacks off the `Data.Aeson.Value` type.++  This module provided for the convenience of users who wish to use the+  EJsonValue datatype in their own projects.+-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE     OverloadedStrings #-}++module Data.EJson.Aeson where++import Data.Aeson+import Data.EJson.EJson++-- TODO: Consider implementing these translations directly, rather than passing through 'Value'.++-- | A FromJSON instance is provided for EJsonValue in order to be able to+--   take advantage of the Aeson functionality.+--+-- This is not used internally.+instance FromJSON EJsonValue where parseJSON = return . value2EJson++-- | A ToJSON instance is provided for EJsonValue in order to be able to+--   take advantage of the Aeson functionality.+--+-- This is not used internally.+instance ToJSON   EJsonValue where toJSON    = ejson2value
+ src/Data/EJson/EJson.hs view
@@ -0,0 +1,218 @@+{-|++  Description : Internal definitions for EJson functionality++  Currently EJson functionality is built on top of the+  `Data.Aeson.Value` type.++  Functions are written to convert back and forth between+  `Data.EJson.EJsonValue` and `Data.Aeson.Value`.++  This has some negative impact on performance, but aids simplicity.++-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE     RankNTypes #-}+{-# LANGUAGE     TemplateHaskell #-}+{-# LANGUAGE     OverloadedStrings #-}+{-# LANGUAGE     TypeSynonymInstances #-}+{-# LANGUAGE     MultiParamTypeClasses #-}++module Data.EJson.EJson (++             EJsonValue(..)++             -- Conversion functions+             , value2EJson+             , ejson2value++             -- Smart Constructors+             , ejobject+             , ejarray+             , ejstring+             , ejnumber+             , ejbool+             , ejdate+             , ejbinary+             , ejuser+             , ejnull++   ) where++import Data.Monoid+import Control.Monad+import Data.Aeson+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.Base64+import Data.String++-- Time+import Data.Convertible+import System.Posix.Types (EpochTime)++data EJsonValue =+    EJObject !(Data.HashMap.Strict.HashMap Text EJsonValue)+  | EJArray  !(Data.Vector.Vector EJsonValue)+  | EJString !Text+  | EJNumber !Scientific+  | EJBool   !Bool+  | EJDate   !EpochTime+  | EJBinary !ByteString+  | EJUser   !Text !EJsonValue+  | EJNull+  deriving (Eq, Show)++instance IsString EJsonValue+  where+  fromString = EJString . Data.Convertible.convert++instance Monoid EJsonValue+  where+  mempty = EJNull++  EJObject o1 `mappend` EJObject o2 = EJObject $ mappend o1 o2+  EJArray  a1 `mappend` EJArray  a2 = EJArray  $ mappend a1 a2+  _           `mappend` _           = error "TODO: Haven't considered what to do here yet..."++-- TODO: Decide what to do about these error cases+instance Num EJsonValue+  where+  fromInteger = EJNumber . fromIntegral+  (EJNumber a) + (EJNumber b) = EJNumber (a + b)+  _            + _            = error "don't add non-numbers"+  (EJNumber a) * (EJNumber b) = EJNumber (a * b)+  _            * _            = error "don't multiply non-numbers"+  abs (EJNumber a)            = EJNumber (abs a)+  abs _                       = error "don't abolute non-numbers"+  signum (EJNumber a)         = EJNumber (signum a)+  signum _                    = error "don't signum non-numbers"+  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++{-# Inline ejarray #-}+ejarray :: [EJsonValue] -> EJsonValue+ejarray = EJArray . Data.Vector.fromList++{-# Inline ejstring #-}+ejstring :: Text -> EJsonValue+ejstring = EJString++{-# Inline ejnumber #-}+ejnumber :: Scientific -> EJsonValue+ejnumber = EJNumber++{-# Inline ejbool #-}+ejbool :: Bool -> EJsonValue+ejbool = EJBool++{-# Inline ejdate #-}+ejdate :: EpochTime -> EJsonValue+ejdate = EJDate++{-# Inline ejbinary #-}+ejbinary :: ByteString -> EJsonValue+ejbinary = EJBinary++{-# Inline ejuser #-}+ejuser :: Text -> EJsonValue -> EJsonValue+ejuser = EJUser++{-# Inline ejnull #-}+ejnull :: EJsonValue+ejnull = EJNull+++-- Helpers++simpleKey :: Text -> Object -> Maybe Value+simpleKey k = Data.HashMap.Strict.lookup k++integer2date :: Integer -> EpochTime+integer2date = Data.Convertible.convert++parseDate :: Value -> Maybe EJsonValue+parseDate (Number n) = Just $ EJDate $ integer2date $ round n+parseDate _          = Nothing++parseBinary :: Value -> Maybe EJsonValue+parseBinary (String s) = Just (EJBinary (decodeLenient (encodeUtf8 s)))+parseBinary _          = Nothing++parseUser :: Value -> Value -> Maybe EJsonValue+parseUser (String k) v = Just $ EJUser k (value2EJson v)+parseUser _          _ = Nothing++parseEscaped :: Value -> Maybe EJsonValue+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++simpleObj :: HashMap Text Value -> EJsonValue+simpleObj o = EJObject $ Data.HashMap.Strict.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)]
+ src/Data/EJson/Prism.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.EJson.Prism where++-- External Imports++import Data.Text+import Control.Lens+import Data.HashMap.Strict++-- Internal Imports++import Data.EJson.EJson+++-- TODO: Remove this "helpful" documentation++-- prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+--+-- type Prism s t a b =+-- forall (p :: * -> * -> *) (f :: * -> *).+-- (Choice p, Control.Applicative.Applicative f) =>+-- p a (f b) -> p s (f t)+--+-- prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b+--+-- preview ::+-- Control.Monad.Reader.Class.MonadReader s m =>+-- Getting (Data.Monoid.First a) s a -> m (Maybe a)+--+-- _Just :: Prism (Maybe a) (Maybe b) a b+-- _Just = prism Just $ maybe (Left Nothing) Right+--+-- _Left :: Prism (Either a c) (Either b c) a b+-- _Left = prism Left $ either Right (Left . Right)+--+-- _Right :: Prism (Either c a) (Either c b) a b+-- _Right = prism Right $ either (Left . Left) Right+--+-- _EJObject :: Text -> Prism EJsonValue (Maybe EJsonValue) EJsonValue EJsonValue++_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 :: 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"
+ src/Main.hs view
@@ -0,0 +1,23 @@+module Main (main) where++import System.Environment+import Web.DDP.Deadpan++main :: IO ()+main = getArgs >>= go++go :: [String] -> IO ()+go xs | hashelp xs = help+go [url]           = run $ getURI url+go _               = help++run :: Either Error Params -> IO ()+run (Left  err   ) = print err+run (Right params) = do logger <- loggingClient+                        runClient logger params (liftIO $ void getLine)++hashelp :: [String] -> Bool+hashelp xs = any (flip elem xs) (words "-h --help")++help :: IO ()+help = putStrLn "Usage: deadpan [-h | --help] <URL>"
+ src/Web/DDP/Deadpan.hs view
@@ -0,0 +1,85 @@+{-|++Description: A collection of utilities to provide a way to create and run Deadpan apps.++A collection of utilities to provide a way to create and run Deadpan apps.++This should be the only Deadpan module imported by users intending to use Deadpan as a library+in order to write DDP applications.++-}+++{-# LANGUAGE OverloadedStrings #-}++module Web.DDP.Deadpan+  ( module Web.DDP.Deadpan+  , module Control.Monad+  , getURI+  , Error+  , Params+  , liftIO+  )+  where++import Web.DDP.Deadpan.DSL+import Web.DDP.Deadpan.Websockets+import Web.DDP.Deadpan.Callbacks as C++import Data.Map+import Control.Concurrent.STM+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.+--+runClient :: AppState Callback -> Params -> DeadpanApp a -> IO a+runClient state params app = flip execURI params+                  $ \conn -> fmap fst $ runDeadpan (setup >> app) conn state++-- | 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".+--+--   Useful for running one-shot command-set applications... Not much else.+--+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" C.pingCallback) values+++-- | A client that logs all server sent messages, responds to pings++loggingClient :: IO (AppState Callback)+loggingClient = do+  values <- newTVarIO (ejobject [])+  return $ AppState (liftIO . print) (Data.Map.singleton "ping" C.pingCallback) values+++-- | A client that responds to server collection messages.+--+--   TODO: NOT YET IMPLEMENTED++collectiveClient :: IO (AppState Callback)+collectiveClient = undefined
+ src/Web/DDP/Deadpan/Callbacks.hs view
@@ -0,0 +1,104 @@+{-|++Description: Intended to provide a set of callbacks for various server events.++This module is intended to provide a set of callbacks for various server events.++The set of callbacks provided fulfills the functionality require to be able+to implement a local data-store reflecting server-sent data-update messages.++"Web.DDP.Deadpan.Callbacks" is used frequently in "Web.DDP.Deadpan".++-}++{-# LANGUAGE OverloadedStrings #-}++module Web.DDP.Deadpan.Callbacks where++import Web.DDP.Deadpan.DSL+import Control.Lens++-- Old Stuff...++-- Client -->> Server++-- Client Heartbeat++pingCallback :: Callback+pingCallback ejv = do+  let mpid = ejv ^? _EJObject "id"+  case mpid of Just pid -> sendMessage "pong" $ ejobject [("id", pid)]+               Nothing  -> sendMessage "pong" $ ejobject []++-- Client Data Subscriptions++clientDataSub :: Text -> Text -> Maybe [ EJsonValue ] -> DeadpanApp ()+clientDataSub _subid _name _params = undefined++-- | Synonym for `clientDataSub`+subscribe :: Text -> Text -> Maybe [ EJsonValue ] -> DeadpanApp ()+subscribe = clientDataSub++clientDataUnsub :: Text -> DeadpanApp ()+clientDataUnsub _subid = undefined++-- | Synonym for `clientDataUnsub`+unsubscribe :: Text -> DeadpanApp ()+unsubscribe = clientDataUnsub+++-- Client RPC++{- |+  As explained in the Meteor DDP documentation:++  @+      method:     string                        (method name)+      params:     optional array of EJSON items (parameters to the method)+      id:         string                        (an arbitrary client-determined identifier for this method call)+      randomSeed: optional JSON value           (an arbitrary client-determined seed for pseudo-random generators)+  @+-}+clientRPCMethod :: Text -> Maybe [EJsonValue] -> Text -> Maybe EJsonValue -> DeadpanApp ()+clientRPCMethod _method _params _rpcid _seed = undefined+++-- Server -->> Client++-- Server Data Subscriptions++serverDataNosub :: Callback+serverDataNosub = undefined++serverDataAdded :: Callback+serverDataAdded = undefined++serverDataChanged :: Callback+serverDataChanged = undefined++serverDataRemoved :: Callback+serverDataRemoved = undefined++serverDataReady :: Callback+serverDataReady = undefined++serverDataAddedBefore :: Callback+serverDataAddedBefore = undefined++serverDataMovedBefore :: Callback+serverDataMovedBefore = undefined+++-- Server RPC++serverRPCResult :: Callback+serverRPCResult  = undefined++serverRPCUpdated :: Callback+serverRPCUpdated = undefined+++-- Server Errors++serverError :: Callback+serverError = undefined
+ src/Web/DDP/Deadpan/Comms.hs view
@@ -0,0 +1,37 @@+{-|++Description: Basic communication primitives for DDP.++This module includes the two basic communication primitives required+for a DDP client:++* Sending   (sendEJ)+* Recieving (getEJ)++These functions are included in a seperate module in order+to avoid recursive moldule import issues.++This module is intended for internal use.++-}++module Web.DDP.Deadpan.Comms (sendEJ, getEJ) where++-- Internal Imports:++import Data.EJson++-- External Imports:++import qualified Network.WebSockets as WS+import qualified Data.Aeson         as J++-- Off we go!++-- | Sends an EJsonValue to the server over the connection provided.+sendEJ :: WS.Connection -> EJsonValue -> IO ()+sendEJ c = WS.sendTextData c . J.encode . ejson2value++-- | Possibly gets an EJsonValue from the server over the connection provided+getEJ :: WS.Connection -> IO (Maybe EJsonValue)+getEJ = fmap (fmap value2EJson . J.decode) . WS.receiveData
+ src/Web/DDP/Deadpan/DSL.hs view
@@ -0,0 +1,203 @@+{-|++Description: An EDSL designed to make writing deadpan applications easy!++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+@++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.++The main functions exported are...++TODO: Ensure these are up to date...++* rundeadpan+* sethandler+* deletehandler+* setdefaulthandler+* senddata+* sendmessage++these allow you to...++* run a deadpan application with some initial set of callbacks+* set new values for response handlers+* delete existing response handlers+* set a handler to act when no existing handler matches the incomming message+* send an ejsonvalue to the server (low-level)+* send messages to be interpreted as rpc calls++... respectively.++There is also a `control.lens.lens` `collections` provided into a single ejsonvalue.++This can be used to...++* Retrieve any current collection data+* Set collection data manually+* Perform actions on collection data in callbacks++-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Web.DDP.Deadpan.DSL+  ( module Web.DDP.Deadpan.DSL+  , module Data.EJson+  , module Data.EJson.Prism+  , module Data.Text+  )+  where++-- External Imports++import Control.Concurrent.STM+import Control.Concurrent+import Control.Applicative+import Network.WebSockets+import Control.Monad.RWS+import Control.Lens+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++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+  }++makeLenses ''AppState++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+  }++instance Monad DeadpanApp where+  return  = DeadpanApp . return+  s >>= f = DeadpanApp $ _deadpanApp s >>= _deadpanApp . f++instance Functor DeadpanApp where+  fmap f (DeadpanApp m) = DeadpanApp $ fmap f m++instance Applicative DeadpanApp where+  pure = DeadpanApp . pure+  (DeadpanApp f) <*> (DeadpanApp m) = DeadpanApp (f <*> m)++instance MonadIO DeadpanApp where+  liftIO i = DeadpanApp $ liftIO i++makeLenses ''DeadpanApp++-- | The order of these args match that of runRWST+--+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)++-- TODO: Use a deadpan app in place of a callback+setHandler :: Text -> Callback -> DeadpanApp ()+setHandler k cb = DeadpanApp $ callbackSet %= insert k cb++-- TODO: should I add getHandler/modifyHandler?++deleteHandler :: Text -> DeadpanApp ()+deleteHandler k = DeadpanApp $ callbackSet %= delete k++-- TODO: Once we have stabalised the definition of Callback+--       we can make better use of the 'a' parameter...++setDefaultHandler :: Callback -> DeadpanApp ()+setDefaultHandler cb = DeadpanApp $ defaultCallback .= cb++-- | 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++-- | Send a particular type of message (indicated by the key) to the server.+--   This should be the primary means of [client -> server] communication by+--   a client application.+sendMessage :: Text -> EJsonValue -> DeadpanApp ()+sendMessage key m = sendData messageData+  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 app = do+  conn     <- DeadpanApp ask+  appState <- DeadpanApp get+  void $ liftIO $ forkIO $ void $ runDeadpan app conn appState++setup :: DeadpanApp ()+setup = do connect+           fork      $+             forever $ do as      <- getAppState+                          message <- getServerMessage+                          respondToMessage (_callbackSet as) (_defaultCallback as) message++getServerMessage :: DeadpanApp (Maybe EJsonValue)+getServerMessage = DeadpanApp $ ask >>= liftIO . getEJ++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++  case maybeCallback of Just    cb -> cb    message+                        Nothing    -> defCb message
+ src/Web/DDP/Deadpan/Websockets.hs view
@@ -0,0 +1,55 @@+{-|++Description : A collection of Websocket functions to ease converting a URI+              and a Deadpan app into an IO result.++A collection of Websocket functions to ease converting a URI and a Deadpan app+into an IO result.++Intended for internal use.++-}++{-# LANGUAGE OverloadedStrings #-}++module Web.DDP.Deadpan.Websockets where++-- External imports+import           Safe                   (readDef)+import           Network.Socket         (withSocketsDo)+import           Data.Text              (Text())+import qualified Network.URI            as U+import qualified Network.WebSockets     as WS++-- TODO: Use better types for these...+type URL    = String+type Domain = String+type Port   = Int+type Path   = String+type Error  = String+type Params = (Domain, Port, Path)++(?>>>) :: Maybe x -> Error -> Either Error x+Just x  ?>>> _ = Right x+Nothing ?>>> e = Left  e++getURI :: String -> Either Error Params+getURI uri = do parsed    <- U.parseURI uri        ?>>> ("Couldn't parse URI [" ++ uri ++ "]")+                autho     <- U.uriAuthority parsed ?>>> ("Couldn't find authority in URI [" ++ show parsed ++ "]")+                let port   = readDef 80 $ drop 1 $ U.uriPort autho+                    domain = U.uriRegName autho+                    path   = U.uriPath parsed+                return (domain, port, path)++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")++execURI :: WS.ClientApp a -> (String, Int, String) -> IO a+execURI app (domain, port, path) = withSocketsDo $ WS.runClient domain port path (setupApp app)++setupApp :: WS.ClientApp a -> WS.ClientApp a+setupApp app conn = do+    res <- app conn+    WS.sendClose conn ("Bye!" :: Text) -- TODO: Do we need this?+    return res