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
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 |]