Permalink
Browse files

works, todo: asynch stuff

  • Loading branch information...
1 parent 1b49912 commit 752e15733a08d93558e113033f2b7a5bca1de605 @exFalso committed Mar 27, 2012
Showing with 139 additions and 5 deletions.
  1. +1 −0 Function.hs
  2. +5 −2 Interface.hs
  3. +4 −1 NowHs.hs
  4. +5 −2 NowHsPrim.hs
  5. +112 −0 client.js
  6. +12 −0 index.html
View
@@ -9,6 +9,7 @@ import Language.Haskell.TH.Lift
import Data.Aeson.TH
data Function = Function { functionName :: Name
+ , functionNameRaw :: String -- for client side prettyness
, functionArgTypes :: [SchemaField]
, functionRetType :: SchemaField }
deriving (Show)
View
@@ -33,11 +33,13 @@ genInterface namesR = do
-- uniqify
let names = Set.toList . Set.fromList $ namesR
funs <- mapM genFun names
- funPairs <- ListE <$> zipWithM (\n f -> [| (n, $(return f)) |]) names funs
+ -- mkName . show NEEDED OTHERWISE WONT BE ABLE TO CALL FROM js!!!
+ funPairs <- ListE <$> zipWithM (\n f -> [| (mkName . show $ n,
+ $(return f)) |]) names funs
internal <- [| \(FunctionCall nam vals) ->
let mp = Map.fromList $(return funPairs) in do
case Map.lookup nam mp of
- Nothing -> liftNowHs $ throwError NoSuchFunction
+ Nothing -> liftNowHs $ throwError (NoSuchFunction nam)
Just f -> f vals
|]
external <- [| runState (sequence $(ListE <$> mapM funSchemaNames names)) Set.empty |]
@@ -59,6 +61,7 @@ funSchemaNames nam = do
retF = $(return retSchField)
modify (\s -> foldl (flip Set.insert) s $(ListE <$> anySchemas))
return $ Function { functionName = nam
+ , functionNameRaw = nameBase nam
, functionArgTypes = argFs
, functionRetType = retF }
|]
View
@@ -7,10 +7,13 @@ import Control.Monad.State
import Control.Monad.Error
import Control.Exception
+import Language.Haskell.TH
+
+
import qualified Network.WebSockets as WS
data NowHsError
- = NoSuchFunction
+ = NoSuchFunction Name
| IncorrectNumArgs
| JSONParseError String
deriving (Show, Typeable)
View
@@ -30,5 +30,8 @@ nowHsM iface sink = do
forever $ do
msg <- liftWS WS.receiveData
case decode' msg of
- Nothing -> err $ JSONParseError "Cannot parse as FunctionCall"
- Just fcall -> interfaceInternal iface fcall
+ Nothing -> do
+ err . JSONParseError $ "Cannot parse as FunctionCall: " ++ show msg
+ Just fcall -> do
+ ret <- interfaceInternal iface fcall
+ liftNowHs . liftIO $ WS.sendSink sink . WS.textData $ encode ret
View
112 client.js
@@ -0,0 +1,112 @@
+function NowHs (server, port) {
+
+ this.socket = new WebSocket("ws://" + server + ":" + port);
+
+ this.socket.onopen = function () {
+ console.log("Socket opened");
+ };
+
+ var thisRef = this;
+
+ this.socket.onmessage = function (msg) {
+ var msgJSON = JSON.parse(msg.data);
+
+ var functions = msgJSON[0];
+ var schemas = msgJSON[1];
+
+ // set up schemas
+
+ // first put in dummies
+ thisRef.schemas = {};
+ for (var i in schemas) {
+ thisRef.schemas[schemas[i].schemaName] = {};
+ }
+
+ // now create the schemas
+ for (var i in schemas) {
+
+ var fields = schemas[i].schemaFields;
+ var schema = thisRef.schemas[schemas[i].schemaName];
+ for (var j in fields) {
+ schema[fields[j][0]] = thisRef.createSchemaField (fields[j][1]);
+ }
+ }
+
+ // now for the functions
+
+ // first set up schemafields for the arguments
+ thisRef.funcSchFields = {}
+ for (var i in functions) {
+ thisRef.funcSchFields[functions[i].functionName] = []
+ for (var j in functions[i].functionArgTypes) {
+ thisRef.funcSchFields[functions[i].functionName][j]
+ = thisRef.createSchemaField (functions[i].functionArgTypes[j]);
+ }
+ }
+
+ // now set up wrapper functions
+ for (var i in functions) {
+
+ // using raw name for interface but qualified name internally
+ thisRef[functions[i].functionNameRaw] = function (fun) { // closure needed
+ return function () {
+
+ var schemaFields = thisRef.funcSchFields[fun.functionName];
+
+
+ // check arguments
+ if (arguments.length - 1 !== schemaFields.length) {
+ throw "Arity mismatch: " + schemaFields.length + " arguments + callback expected";
+ }
+
+ for (var arg = 0; arg < arguments.length - 1; arg++) {
+ jsschema.checkField (schemaFields[arg], arguments[arg]);
+ }
+
+ var functionCall = {
+ funName : fun.functionName,
+ funArgs : Array.prototype.slice.call (arguments, 0, arguments.length - 1), // retarded javascript
+ }
+ var jsn = JSON.stringify (functionCall);
+ console.log (jsn);
+ thisRef.socket.send (jsn);
+ // TODO: FIGURE OUT asynchronous calls (generate hash for each fcall?)
+ }
+ } (functions[i]);
+ }
+
+ thisRef.socket.onmessage = function (msg) {
+ console.log ("Yipiieee: " + msg);
+ }
+
+ };
+
+ // returns primitive type or reference to schema
+ this.primOrSchema = function (obj) {
+ switch (obj.type) {
+ case "Prim":
+ return obj.value;
+ case "SchemaName":
+ return this.schemas[obj.value];
+ default:
+ throw ("Cannot happen" + obj.type);
+ }
+ };
+
+ this.createSchemaField = function (schFieldDesc) {
+ switch (schFieldDesc[0]) {
+ case "Required":
+ return jsschema.required (this.primOrSchema (schFieldDesc[1]));
+ break;
+ case "Optional":
+ return jsschema.optional (this.primOrSchema (schFieldDesc[1]));
+ break;
+ case "Repeated":
+ return jsschema.repeated (this.primOrSchema (schFieldDesc[1]));
+ break;
+ default:
+ throw ("Cannot happen: " + schFieldDesc[0]);
+ }
+ };
+}
+
View
@@ -0,0 +1,12 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>
+
+ </title>
+ </head>
+ <body>
+ <script type="text/javascript" src="client.js"></script>
+ <script type="text/javascript" src="jsschema.js"></script>
+ </body>
+</html>

0 comments on commit 752e157

Please sign in to comment.