module Control.Distributed.STM.NameService
(nameService, gDefaultNameServer,
registerTVar, deregisterTVar, lookupTVar) where
import qualified Control.Exception as CE
import Control.Distributed.STM.DebugBase
import Control.Distributed.STM.Dist
import Control.Distributed.STM.EnvAddr
import Control.Distributed.STM.TVar
import Network
import Prelude as P hiding (catch, putStr, putStrLn)
import System.IO
data NameServerMsg = NameServerPing
| NameServerReg String VarLink
| NameServerUnReg String
| NameServerLookup String
deriving (Show, Read)
type TVarDict = [(String, VarLink)]
putNameServerLn :: Show a => String -> a -> IO ()
putNameServerLn nameServer msg = do
debugStrLn0 ("--> putNameServerLn: "++nameServer++" msg: "++(show msg))
h <- connectTo nameServer (PortNumber gNameServerPort)
sendTCP msg h
hClose h
getNameServerLn :: Show a => String -> a -> IO String
getNameServerLn nameServer msg = do
debugStrLn0 ("<-- getNameServerLn: "++nameServer++" msg: "++(show msg))
h <- connectTo nameServer (PortNumber gNameServerPort)
answer <- recvTCP msg h
hClose h
return answer
gDefaultNameServer :: String
gDefaultNameServer = "localhost"
nameService :: String -> IO ()
nameService server = CE.catch (putNameServerLn server NameServerPing)
(\(e::CE.SomeException) -> do
debugStrLn0 ("nameService: start name server: "++ show e)
listenOn (PortNumber gNameServerPort) >>= readNameServerMsg [])
readNameServerMsg :: TVarDict -> Socket -> IO ()
readNameServerMsg tVarDict s = do
debugStrLn0 ("nameService: readNameServerMsg: "++ show s)
(h, _, _) <- accept s
str <- hGetLine h
newTable <- case reads str of
((msg,_):_) -> handleNameServerMsg h msg tVarDict
_ -> return tVarDict
hClose h
readNameServerMsg newTable s
handleNameServerMsg :: Handle -> NameServerMsg -> TVarDict -> IO TVarDict
handleNameServerMsg h msg tVarDict =
case msg of
NameServerPing -> return tVarDict
NameServerReg name tVar -> do
debugStrLn0 ("Registered: "++(show name))
return $ (name, tVar):filter ((name/=).fst) tVarDict
NameServerUnReg name -> do
debugStrLn0 ("Unregistered: "++(show name))
return $ filter ((name/=) . fst) tVarDict
NameServerLookup name -> do
debugStrLn0 ("Lookup: "++(show name))
hPutStrLn h (show (lookup name tVarDict))
return tVarDict
registerTVar :: Dist a => String -> TVar a -> String -> IO ()
registerTVar server tVar name = CE.catch (do
debugStrLn0 ("registerTVar: " ++ show tVar ++ " " ++ name)
putNameServerLn server (NameServerReg name (tVarToLink tVar))
regTVars gMyEnv tVar
)(propagateEx "registerTVar")
deregisterTVar :: String -> String -> IO ()
deregisterTVar server name = CE.catch (do
debugStrLn0 ("deregisterTVar: " ++ show name)
putNameServerLn server (NameServerUnReg name)
)(propagateEx "deregisterTVar")
lookupTVar :: forall a . Dist a => String -> String -> IO (Maybe (TVar a))
lookupTVar server name = CE.catch (do
debugStrLn0 ("lookupTVar: " ++ server ++ " , " ++ name)
answer <- getNameServerLn server (NameServerLookup name)
debugStrLn0 ("lookupTVar: " ++ show answer)
case reads answer of
((Just link,_):_) -> do
let tVar::TVar a = LinkTVar link
finTVars tVar
return $ Just tVar
_ -> return Nothing
)(propagateEx "lookupTVar")