diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Gershom Bazerman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Gershom Bazerman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/JMacroRPC/Base.hs b/Network/JMacroRPC/Base.hs new file mode 100644 --- /dev/null +++ b/Network/JMacroRPC/Base.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE QuasiQuotes, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, UndecidableInstances #-} + +{- | +Module : Network.JMacroRPC.Base +Copyright : (c) Gershom Bazerman, 2012 +License : BSD 3 Clause +Maintainer : gershomb@gmail.com +Stability : experimental + +The jmacro-rpc library provides an implementation of the JSON-RPC 2.0 protocol in Haskell (http://www.jsonrpc.org/), using typeclass based induction to automatically wrap arbitrary Haskell functions up as exposed RPCs, and to generate Haskell functions to call those RPCs on a remote server. Facilities are also included to expose RPCs in javascript on generated HTML pages, and to manage page-local (i.e. "conversation") state on these pages. This package provides all core functionality and APIs. Additional backend-specific packages are provided for wiring these functions up to existing HTTP server packages. + +-} + +module Network.JMacroRPC.Base where + +import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) +import Control.Applicative +import Control.Arrow((***)) +import Control.Concurrent +import Control.Monad.Trans +import Data.Aeson +import Data.Attoparsec.Lazy +import Data.Attoparsec.Number +import Data.Char(toLower) +import Data.Foldable(foldMap) +import qualified Data.IntMap as IM +import Data.Monoid +import Data.List(find) +import Data.Text(unpack) +import Data.Vector(toList) + +import qualified Data.ByteString.Lazy.Char8 as BL + +import qualified Data.Map as M +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + +import Language.Javascript.JMacro + +-- Throat Clearing + +instance ToJExpr Value where + toJExpr Null = ValExpr $ JVar $ StrI "null" + toJExpr (Bool b) = ValExpr $ JVar $ StrI $ map toLower (show b) + toJExpr (Number n) = ValExpr $ JDouble $ realToFrac n + toJExpr (String s) = ValExpr $ JStr $ unpack s + toJExpr (Array vs) = ValExpr $ JList $ map toJExpr $ toList vs + toJExpr (Object obj) = ValExpr $ JHash $ M.fromList $ map (unpack *** toJExpr) $ HM.toList obj + +-- | A JSON request is a list of values +type JRequest = [Value] + +-- | A JSON result is either an error or a value. +type JResult = Either String Value + +-- | A JsonRPC is a named function that takes a handle to some state, and yields a function from request to result in some monad. It is a representation of the server side of an RPC call. +data JsonRPC m s = JsonRPC String (s -> JRequest -> m JResult) + +-- | retErr = return . Left +retErr :: Monad m => a -> m (Either a b) +retErr s = return $ Left s + +-- To RPCs/Server Side + +-- | This class should not be used directly. +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" + +-- | Takes a compatible function to a JsonRPC. +toJsonRPC :: ToJsonRPC a m => String -> a -> JsonRPC m () +toJsonRPC nm f = JsonRPC nm $ \() -> toJsonRPC_ f + +-- | Takes a compatible function to a JsonRPC making use of state (i.e. a conversation). +toJsonConvRPC :: ToJsonRPC a m => String -> (s -> a) -> JsonRPC m s +toJsonConvRPC nm f = JsonRPC nm (\s -> toJsonRPC_ (f s)) + +-- Client Side + +-- | This class should not be used directly. +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) + + +-- | Send a function on Jsonable values to a function of the same signature whose logic is invokable on a remote server. This function operates on the type of its argument. The body can remain undefined. +toJsonRPCCall :: ToJsonRPCCall a b => a -> b +toJsonRPCCall x = toJsonRPCCall_ [] x + +-- | Takes a name and a function and yields both the server-side JsonRPC and the client-side stub. +mkJsonRPCPair :: (ToJsonRPC a m, ToJsonRPCCall a t) => + String -> (s -> a) -> (t, JsonRPC m s) +mkJsonRPCPair nm f = (toJsonRPCCall_ [] (f undefined), toJsonConvRPC nm f) + + +-- | JMacro Javascript stub to invoke json-rpc calls from web browsers. +invokeRPCLib :: JStat +invokeRPCLib = + [$jmacro| + var !jmacro_rpc_id = 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 (res.error + ""); + } + } + |] + +-- | id with a helpful type. +asIO :: IO a -> IO a +asIO = id + +-- | Given a function for managing local state, and a list of JsonRPCs over that local state, produce a function from Bytestring to Bytestring mapping json-rpc requests to responses. +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)] + +-- | Used for creating server backends. Yes, this type is confusing. But unless you are creating a server backend, you can ignore it. Takes a function to generate some time identifier, a function to cull page state, a rpc handler, a function for creating a single page, a function to initialize a page state, and a bunch of rpcs, and creates a pair of handler functions (one for POST and one for GET) such that individual clients first pull a page with an embedded ID, along with client-side rpc functions. Those functions in turn interact with state local to that invocation of a page when they make json-rpc requests to the server. The cull function is in IO so it has access to whatever notion of time it desires, including the opportunity to not run at all. +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 + return (IM.insert ident (t,s) m,s) + genJs = do + i <- liftIO $ modifyMVar identSupply $ \is -> return (is+1,is) + return $ invokeRPCLib + `mappend` + [$jmacro| + var !serverLoc = window.location.href.split(/[?#]/)[0]; + jmacro_rpc_id = `(i)`; + |] + `mappend` + foldMap toDecl rpcs + toDecl (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); + } + |] + ] + return $ (rpcFun stateFun rpcs, pageFun =<< genJs) + + +type JState a = MVar (Either String a) +type JStateAsync a = MVar (Either (Int, String) (JState a)) 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/jmacro-rpc.cabal b/jmacro-rpc.cabal new file mode 100644 --- /dev/null +++ b/jmacro-rpc.cabal @@ -0,0 +1,27 @@ +Name: jmacro-rpc +Version: 0.1 +Homepage: http://patch-tag.com/r/gershomb/jmacro-rpc +License: BSD3 +License-file: LICENSE +Author: Gershom Bazerman +Maintainer: gershomb@gmail.com +Category: Network +Build-type: Simple +Cabal-version: >=1.6 + +Synopsis: JSON-RPC clients and servers using JMacro. + +Description: Base jmacro-rpc package. Provides server-idependent functions. + +Library + Exposed-modules: Network.JMacroRPC.Base + -- , Network.JMacroRPC.Http + + Build-depends: base >= 4, base < 7, jmacro > 0.5, text > 0.11, containers >= 0.4, bytestring >= 0.9.1, vector >= 0.8, attoparsec > 0.10, aeson >= 0.6, mtl > 2, unordered-containers > 0.1.4 + --, network > 2, HTTP > 4000 + + ghc-options: -Wall + +source-repository head + type: darcs + location: http://patch-tag.com/r/gershomb/jmacro-rpc