module Network.JMacroRPC.Base where
import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read)
import Control.Applicative
import Control.Concurrent
import Control.Monad.Trans
import Data.Aeson
import Data.Attoparsec.Lazy
import Data.Attoparsec.Number
import Data.Foldable(foldMap)
import qualified Data.IntMap as IM
import Data.Monoid
import Data.List(find)
import Data.Vector(toList)
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import Language.Javascript.JMacro
type JRequest = [Value]
type JResult = Either String Value
data JsonRPC m s = JsonRPC String (s -> JRequest -> m JResult)
retErr :: Monad m => a -> m (Either a b)
retErr s = return $ Left s
class Monad m => ToJsonRPC a m | a -> m where
toJsonRPC_ :: a -> ([Value] -> m JResult)
instance (ToJSON b) => ToJsonRPC (IO (Either String b)) IO where
toJsonRPC_ f = \ _ -> fmap (fmap toJSON) $ f
instance (FromJSON a, ToJsonRPC b m) => ToJsonRPC (a -> b) m where
toJsonRPC_ f (x:xs) = case fromJSON x of
Error s -> retErr s
Success v -> toJsonRPC_ (f v) xs
toJsonRPC_ _ [] = retErr "insufficient arguments"
toJsonRPC :: ToJsonRPC a m => String -> a -> JsonRPC m ()
toJsonRPC nm f = JsonRPC nm $ \() -> toJsonRPC_ f
toJsonConvRPC :: ToJsonRPC a m => String -> (s -> a) -> JsonRPC m s
toJsonConvRPC nm f = JsonRPC nm (\s -> toJsonRPC_ (f s))
class ToJsonRPCCall a b | a -> b where
toJsonRPCCall_ :: [Value] -> a -> b
instance FromJSON b => ToJsonRPCCall (IO (Either String b)) ((BL.ByteString -> IO (Either String BL.ByteString)) -> Value -> String -> IO (Either String b)) where
toJsonRPCCall_ xs _ = \remoteCall ident method -> do
res <- remoteCall $ encode $ object
[
(T.pack "params" , toJSON $ reverse xs),
(T.pack "jsonrpc", toJSON "2.0"),
(T.pack "method" , toJSON method),
(T.pack "id", ident)
]
return $ either (Left . id) toVal res
where
toVal bs =
case eitherResult $ parse json bs of
Left err -> Left err
Right v ->
case v of
Object m ->
case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","result","id"] of
Just [String code, res, Number _] ->
if code /= T.pack "2.0"
then Left "bad protocol version"
else case fromJSON res of
Error str -> Left str
Success a -> Right a
_ -> Left $ "bad return val " ++ show v
_ -> Left $ "bad return val" ++ show v
instance (ToJSON a, ToJsonRPCCall b c) => ToJsonRPCCall (a -> b) (a -> c) where
toJsonRPCCall_ xs f = \x -> toJsonRPCCall_ (toJSON x : xs) (f x)
toJsonRPCCall :: ToJsonRPCCall a b => a -> b
toJsonRPCCall x = toJsonRPCCall_ [] x
mkJsonRPCPair :: (ToJsonRPC a m, ToJsonRPCCall a t) =>
String -> (s -> a) -> (t, JsonRPC m s)
mkJsonRPCPair nm f = (toJsonRPCCall_ [] (f undefined), toJsonConvRPC nm f)
invokeRPCLib :: JStat
invokeRPCLib =
[jmacro|
var !jmacro_rpc_id = 0;
var !serverLoc = window.location.href.split(/[?#]/)[0];
fun invokeJsonRPC serverLoc method args {
var res;
$.ajax({type : "POST",
url : serverLoc,
data : JSON.stringify
{
params: args,
jsonrpc: "2.0",
method: method,
id: jmacro_rpc_id
},
success : \d {res = d},
dataType: "json",
async : false
});
if(res.result) {
return res.result;
} else {
alert (method + ": " + res.error.message + "");
}
}
|]
asIO :: IO a -> IO a
asIO = id
handleRpcs :: (Functor m, Monad m) => (Int -> m s) -> [JsonRPC m s] -> BL.ByteString -> m BL.ByteString
handleRpcs getS rpcs bs = encode <$>
case eitherResult $ parse json bs of
Left err -> return $ errToVal Nothing (32700) err
Right v ->
case v of
Object m -> case mapM (\x -> HM.lookup (T.pack x) m) ["jsonrpc","method","params","id"] of
Just [String code, String meth, Array params, Number ident] ->
if code /= T.pack "2.0"
then return $ errToVal (Just $ toInt ident) (32600) "wrong protocol version -- server requires 2.0"
else case find (\(JsonRPC n _) -> n == T.unpack meth) rpcs of
Just (JsonRPC _ f) -> jresToVal (toInt ident) <$> (flip f (toList params) =<< getS (toInt ident))
Nothing -> return $ errToVal (Just $ toInt ident) (32601) $ "no method defined " ++ (T.unpack meth)
_ -> do
return $ errToVal Nothing (32602) $ "bad params passed, require jsonrpc, method, params, id"
_ -> return $ errToVal Nothing (32700) "not passed an object"
where
toInt (I i) = fromIntegral i
toInt (D d) = round d
jresToVal :: Int -> JResult -> Value
jresToVal ident jres =
object $
[(T.pack "jsonrpc", toJSON "2.0"),
(T.pack "id", toJSON ident)] ++
case jres of
Right r -> [(T.pack "result", r)]
Left e -> [(T.pack "error", eobj 0 e)]
eobj :: Int -> String -> Value
eobj ecode msg = object [(T.pack "code",toJSON ecode),(T.pack "message",toJSON msg)]
errToVal :: Maybe Int -> Int -> String -> Value
errToVal mident ecode msg = object $
[(T.pack "jsonrpc", toJSON "2.0"),
(T.pack "id", maybe Null toJSON mident),
(T.pack "error", eobj ecode msg)]
mkConversationPageGen :: (MonadIO m1, MonadIO m) =>
IO timestamp
-> (IM.IntMap (timestamp,s) -> IO (IM.IntMap (timestamp,s)))
-> ((Int -> m s) -> [JsonRPC m s] -> m1 resp)
-> (JStat -> m1 resp)
-> IO s
-> [JsonRPC m s]
-> IO (m1 resp, m1 resp)
mkConversationPageGen getStamp cullMap rpcFun pageFun emptyState rpcs = do
mp <- newMVar (IM.empty :: IM.IntMap s)
identSupply <- newMVar (1 :: Int)
let
stateFun ident = liftIO $ modifyMVar mp $ \m -> case IM.lookup ident m of
Just (_,res) -> do
t <- getStamp
newMap <- cullMap $ IM.insert ident (t,res) m
return (newMap, res)
Nothing -> do
s <- emptyState
t <- getStamp
m' <- cullMap m
return (IM.insert ident (t,s) m',s)
genJs = do
i <- liftIO $ modifyMVar identSupply $ \is -> return (is+1,is)
return $ invokeRPCLib
`mappend`
[jmacro|
jmacro_rpc_id = `(i)`;
|]
`mappend`
foldMap jsonRPCToDecl rpcs
return $ (rpcFun stateFun rpcs, pageFun =<< genJs)
jsonRPCToDecl :: JsonRPC a m -> JStat
jsonRPCToDecl (JsonRPC n _) =
BlockStat [
DeclStat (StrI n) Nothing,
AssignStat (ValExpr $ JVar $ StrI n)
[jmacroE|\ {
var a = Array.prototype.slice.call(arguments);
return (invokeJsonRPC (serverLoc + "jrpcs") `(n)` a);
}
|]
]
type JState a = MVar (Either String a)
type JStateAsync a = MVar (Either (Int, String) (JState a))