diff --git a/Deadpan-DDP.cabal b/Deadpan-DDP.cabal new file mode 100644 --- /dev/null +++ b/Deadpan-DDP.cabal @@ -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. + . + is the protocol that + 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 + into the triple (Right ("localhost", 3000, "websocket"))... + or an error (Left "error message"). + . + Refer to the 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/EJson.hs b/src/Data/EJson.hs new file mode 100644 --- /dev/null +++ b/src/Data/EJson.hs @@ -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: + + + + 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 diff --git a/src/Data/EJson/Aeson.hs b/src/Data/EJson/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/EJson/Aeson.hs @@ -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 diff --git a/src/Data/EJson/EJson.hs b/src/Data/EJson/EJson.hs new file mode 100644 --- /dev/null +++ b/src/Data/EJson/EJson.hs @@ -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)] diff --git a/src/Data/EJson/Prism.hs b/src/Data/EJson/Prism.hs new file mode 100644 --- /dev/null +++ b/src/Data/EJson/Prism.hs @@ -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" diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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] " diff --git a/src/Web/DDP/Deadpan.hs b/src/Web/DDP/Deadpan.hs new file mode 100644 --- /dev/null +++ b/src/Web/DDP/Deadpan.hs @@ -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 diff --git a/src/Web/DDP/Deadpan/Callbacks.hs b/src/Web/DDP/Deadpan/Callbacks.hs new file mode 100644 --- /dev/null +++ b/src/Web/DDP/Deadpan/Callbacks.hs @@ -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 diff --git a/src/Web/DDP/Deadpan/Comms.hs b/src/Web/DDP/Deadpan/Comms.hs new file mode 100644 --- /dev/null +++ b/src/Web/DDP/Deadpan/Comms.hs @@ -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 diff --git a/src/Web/DDP/Deadpan/DSL.hs b/src/Web/DDP/Deadpan/DSL.hs new file mode 100644 --- /dev/null +++ b/src/Web/DDP/Deadpan/DSL.hs @@ -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 diff --git a/src/Web/DDP/Deadpan/Websockets.hs b/src/Web/DDP/Deadpan/Websockets.hs new file mode 100644 --- /dev/null +++ b/src/Web/DDP/Deadpan/Websockets.hs @@ -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