jmacro-rpc (empty) → 0.1
raw patch · 4 files changed
+309/−0 lines, 4 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, bytestring, containers, jmacro, mtl, text, unordered-containers, vector
Files
- LICENSE +30/−0
- Network/JMacroRPC/Base.hs +250/−0
- Setup.hs +2/−0
- jmacro-rpc.cabal +27/−0
+ LICENSE view
@@ -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.
+ Network/JMacroRPC/Base.hs view
@@ -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))
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jmacro-rpc.cabal view
@@ -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