rpc (empty) → 0.0.0

raw patch · 10 files changed

+281/−0 lines, 10 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, derive, network-fancy, template-haskell, th-lift

Files

• Data/Serialize/Send.hs +19/−0
• LICENSE +20/−0
• Network/RPC/Client.hs +40/−0
• Network/RPC/Server.hs +60/−0
• Network/RPC/Types.hs +71/−0
• Setup.lhs +3/−0
• rpc.cabal +17/−0
• tests/ctest.hs +24/−0
• tests/stest.hs +15/−0
• tests/test.hs +12/−0

@@ -0,0 +1,19 @@+module Data.Serialize.Send (hSerialize, hDeserialize) where+import System.IO (hFlush, Handle)+import Data.Serialize+import Data.Serialize.Put+import Data.Serialize.Get+import Data.ByteString as B+import Control.Monad++-- |Serializes an object to the given handle+hSerialize :: Serialize a => Handle -> a -> IO ()+hSerialize h x = hPut h $ runPut (putWord8 (fromIntegral (B.length a))) `append` a+    where a = encode x++-- |Deserializes an object to the given handle+hDeserialize :: Serialize a => Handle -> IO a+hDeserialize h = do+    (Right l) <- liftM (runGet getWord8) (hGet h 1)+    (Right x) <- liftM decode (hGet h (fromIntegral l))+    return x

@@ -0,0 +1,20 @@+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. 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.++THIS SOFTWARE IS PROVIDED ``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+DEVELOPERS AND 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.

@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}++module Network.RPC.Client (fetch, Address(..)) where+import Network.Fancy+import Data.Serialize.Send+import Control.Monad+import Language.Haskell.TH+import System.IO (hFlush)+import Network.RPC.Types++-- |Splices in rpc calls to a given IP.  Function names and types will remain the same as+-- on the server side, with the result encapsulated in the IO monad.  Usage:+--+-- >    $(fetch (IP "127.0.0.1" 9000))+fetch :: Address -> Q [Dec]+fetch a = runIO $ withStream a $ \h-> do+    hSerialize h GetTypes >> hFlush h+    xs <- hDeserialize h :: IO [FuncSpec]+    let funcs = map (\(FuncSpec n _)-> mkName n) xs+    runQ $ liftM (++ (zipWith addType funcs xs)) (zipWithM (makeFunc a) funcs xs)++makeFunc :: Address -> Name -> FuncSpec -> Q Dec+makeFunc a n (FuncSpec f t) = do+    args <- replicateM (walkApps t 0) (newName "x")+    let pats = map varP args+    let exprs = return $ ListE $ map (AppE (ConE 'Bin) . VarE) args+    let e = [|(\toSer-> withStream a $ \h-> hSerialize h (CallFunc f) >>+                mapM (\(Bin a)-> hSerialize h a) toSer >> hFlush h >> hDeserialize h) $exprs|]+    funD n [clause pats (normalB e)[]]++addType :: Name -> FuncSpec -> Dec+addType n (FuncSpec _ t) = SigD n (addIO (specToType t))++addIO (AppT a b) = (AppT a (addIO b))+addIO (ForallT ns c t) = (ForallT ns c (addIO t))+addIO a = (AppT (ConT ''IO) a)++walkApps :: TypeSpec -> Int -> Int+walkApps (SAppT _ a) n = walkApps a (n+1)+walkApps b n = n

@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -ddump-splices #-}++module Network.RPC.Server (share) where+import Network.RPC.Types+import Network.Fancy+import Data.Serialize.Send+import Data.Maybe+import Network.RPC.Types+import qualified Data.Map as Map+import Data.Map (Map)+import Language.Haskell.TH+import System.IO (hFlush)+import Control.Concurrent (ThreadId)+import Language.Haskell.TH.Syntax+import Control.Monad+import Data.List+import System.IO (Handle)++serve :: Address -> (Map String (Handle -> IO ())) -> [FuncSpec] -> IO ()+serve ip funcs types = do+    streamServer (serverSpec {address = ip}) $ \h _-> do+        x <- hDeserialize h+        case x of+            GetTypes -> hSerialize h types+            (CallFunc a) -> fromJust (Map.lookup a funcs) h+        hFlush h+    sleepForever++apps :: ExpQ -> [ExpQ] -> ExpQ+apps f (x:xs) = apps (appE f x) xs+apps f [] = f++buildArgs :: Type -> [Type]+buildArgs (AppT i a) = (unArrow i) : buildArgs a+buildArgs (ForallT _ _ t) = buildArgs t+buildArgs a = []+unArrow (AppT ArrowT i) = i+unArrow a = a++-- |Template haskell magic to share a set of functions on a given port to be spliced into a main declaration.  +-- This function never returns.  For example:+--+-- >    main = $(share 9000 [ 'fn1, 'fn2, 'fn3 ])+share :: Int -> [Name] -> Q Exp+share p gs = [| serve (IP "" p) (Map.fromList $ zip keys $vals) $types |] where+    keys = map nameBase gs+    vals :: Q Exp+    vals = listE $ flip map gs $ \x-> do+                (VarI n t _ _) <- reify x+                hName <- newName "h"+                let argtypes = map (AppT (ConT ''IO)) (buildArgs t)+                let args = zipWith SigE (replicate (length argtypes) (AppE (VarE 'hDeserialize) (VarE hName))) argtypes+                names <- replicateM (length argtypes) (newName "y")+                ret <- noBindS (appE (appE (varE 'hSerialize) (varE hName)) (apps (varE x) (map varE names)))+                lam1E (varP hName) (return $ DoE (zipWith BindS (map VarP names) args ++ [ret]))+    types = listE $ flip map gs $ \x-> do+                (VarI n t _ _) <- reify x+                let spec = lift (typeToSpec t)+                [|FuncSpec $(lift $ nameBase n) $spec |]

@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -fglasgow-exts #-}++module Network.RPC.Types (+    Req(..), FuncSpec(..), TypeSpec(..),+    Bin(..), typeToSpec, specToType+    ) where+import Data.DeriveTH (derive, makeSerialize)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lift+import Network.Fancy+import Data.Serialize+import Control.Monad++data Req = GetTypes | CallFunc String+data FuncSpec = FuncSpec String TypeSpec deriving Show+data TypeSpec = SForallT [TyVarBndrSpec] [PredSpec] TypeSpec |+    SVarT String | SConT String | STupleT Int | SArrowT |+    SListT | SAppT TypeSpec TypeSpec deriving Show+data TyVarBndrSpec = SPlainTV String | SKindedTV String Kind deriving Show+data PredSpec = SClassP String [TypeSpec] | SEqualP TypeSpec TypeSpec deriving Show++data Bin = forall a . Serialize a => Bin a++$(derive makeSerialize ''Req)+$(derive makeSerialize ''FuncSpec)+$(derive makeSerialize ''TypeSpec)+$(derive makeSerialize ''TyVarBndrSpec)+$(derive makeSerialize ''Kind)+$(derive makeSerialize ''PredSpec)++unTV :: TyVarBndr -> TyVarBndrSpec+unTV (PlainTV n) = SPlainTV (nameBase n)+unTV (KindedTV n k) = SKindedTV (nameBase n) k++makeTV :: TyVarBndrSpec -> TyVarBndr+makeTV (SPlainTV n) = PlainTV (mkName n)+makeTV (SKindedTV n k) = KindedTV (mkName n) k++unPred :: Pred -> PredSpec+unPred (ClassP n ts) = SClassP (nameBase n) (map typeToSpec ts)+unPred (EqualP t1 t2) = SEqualP (typeToSpec t1) (typeToSpec t2)++makePred :: PredSpec -> Pred+makePred (SClassP n ts) = ClassP (mkName n) (map specToType ts)+makePred (SEqualP t1 t2) = EqualP (specToType t1) (specToType t2)++typeToSpec :: Type -> TypeSpec+typeToSpec (ForallT ns cs t) = SForallT (map unTV ns) (map unPred cs) (typeToSpec t)+typeToSpec (VarT n) = SVarT (nameBase n)+typeToSpec (ConT n) = SConT (nameBase n)+typeToSpec (TupleT i) = STupleT i+typeToSpec ArrowT = SArrowT+typeToSpec ListT = SListT+typeToSpec (AppT a b) = SAppT (typeToSpec a) (typeToSpec b)++specToType :: TypeSpec -> Type+specToType (SForallT ns cs t) = ForallT (map makeTV ns) (map makePred cs) (specToType t)+specToType (SVarT s) = VarT (mkName s)+specToType (SConT s) = ConT (mkName s)+specToType (STupleT i) = TupleT i+specToType SArrowT = ArrowT+specToType SListT = ListT+specToType (SAppT a b) = AppT (specToType a) (specToType b)++$(deriveLift ''Address)+$(deriveLift ''TypeSpec )+$(deriveLift ''TyVarBndrSpec )+$(deriveLift ''Kind)+$(deriveLift ''PredSpec)

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,17 @@+name:                rpc+version:             0.0.0+synopsis:            type safe rpcs provided as basic IO actions+description:         Given an address of a server sharing a set of functions,+                     this rpc library generates functions of the same name for+                     a client, preformed within the IO monad.  Calling+                     these results in the original function being executed+                     server side.  The pseudo-functions generated maintain+                     their original server side type (except for the added IO).+category:            Network+license:             BSD3+license-file:        LICENSE+author:              Sam Anklesaria+maintainer:          amsay@amsay.net+build-type:          Simple+build-depends:       base >= 3 && < 5, network-fancy < 1, cereal < 1, th-lift < 1, derive < 3, bytestring < 1, template-haskell < 3, containers < 1+exposed-modules:     Data.Serialize.Send, Network.RPC.Client, Network.RPC.Server

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where+import Network.RPC.Client+import Test.HUnit++$(fetch (IP "" 9000))++main = runTestTT $ TestList [+            TestLabel "hello world" hWorld,+            TestLabel "plusOne" plusTest,+            TestLabel "BoolInt" boolTest]++hWorld = TestCase $ do+    a <- helloWorld+    assertEqual "" "hello world" a++plusTest = TestCase $ do+    a <- tester 1+    assertEqual "Plus 1: " 2 a++boolTest = TestCase $ do+    a <- tester2 0 True+    assertEqual "Not True : " False a

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where+import Network.RPC.Server++tester :: Int -> Int+tester = (+1)++helloWorld :: String+helloWorld = "hello world"++tester2 :: Int -> Bool -> Bool+tester2 _ = not++main = $(share 9000 [ 'tester, 'tester2, 'helloWorld ])

@@ -0,0 +1,12 @@+module Main where+import System.Process+import Control.Concurrent++main = do+    c <- runCommand "ghc ./tests/stest.hs --make -o server"+    waitForProcess c+    s <- runCommand "./server"+    threadDelay 1000000+    p <- runCommand "runhaskell ./tests/ctest.hs"+    waitForProcess p+    terminateProcess s