module Language.Javascript.JMacro.Rpc (
mkWebRPC, asIO, Request, Response(..), WebRPCDesc,
CallWebRPC(..),ToWebRPC(..)
) where
import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)
import Language.Javascript.JMacro.Base
import Language.Javascript.JMacro.QQ
import Text.JSON
import Text.JSON.String
type WebRPCDesc = (String, Request -> IO Response)
type Request = String
data Response = GoodResponse String
| BadResponse Int String
returnResp :: JSON a => a -> IO Response
returnResp r = return $ GoodResponse (encode r)
respCode c e = BadResponse c e
badData e = return $ respCode 400 ("Bad Data format: " ++ e)
class ToWebRPC a where
toWebRPC_ :: a -> ([JSValue] -> IO Response)
instance (JSON b) => ToWebRPC (IO b) where
toWebRPC_ f _ = returnResp =<< f
instance (JSON a, ToWebRPC b) => ToWebRPC (a -> b) where
toWebRPC_ f (x:xs) = case readJSON x of
Ok v -> toWebRPC_ (f v) xs
Error s -> badData s
toWebRPC_ _ _ = badData "missing parameter"
toWebRPC :: ToWebRPC a => a -> Request -> IO Response
toWebRPC f = \req -> case runGetJSON readJSArray req of
(Right (JSArray xs)) ->f' xs
(Left e) -> badData e
_ -> badData "toWebRPC error"
where f' = toWebRPC_ f
class CallWebRPC a b | a -> b where
callWebRPC_ :: [JExpr] -> String -> a -> b
instance CallWebRPC (IO b) JExpr where
callWebRPC_ xs serverLoc _ =
[$jmacroE|
(\() { var res;
// $.post(`(serverLoc)`, { args : JSON.stringify `(reverse xs)` }, \(d) {res = d}, "json");
$.ajax({type : "POST",
url : `(serverLoc)`,
data : { args : JSON.stringify `(reverse xs)` },
success : \d {res = d},
dataType: "json",
async : false
});
return res;
}())|]
instance (CallWebRPC b c, ToJExpr d) => CallWebRPC (a -> b) (d -> c) where
callWebRPC_ xs serverLoc f = \x -> callWebRPC_ (toJExpr x : xs) serverLoc (f undefined)
callWebRPC :: (CallWebRPC a b) => String -> a -> b
callWebRPC s f = callWebRPC_ [] s f
mkWebRPC :: (ToWebRPC a, CallWebRPC a b) => String -> a -> (WebRPCDesc, String -> b)
mkWebRPC name rpcFun = ((name,toWebRPC rpcFun), \server -> callWebRPC (server ++ "/" ++ name) rpcFun)
testRPCCall :: String -> JExpr -> JExpr -> JExpr
(testRPC, testRPCCall) = mkWebRPC "test" $ \x y -> asIO $ return (x + (y::Int))
asIO :: IO a -> IO a
asIO = id