Browse Source

monitor service executable to install and run local or remote services at run-time

addedsingle
Alberto G. Corona 6 years ago
parent
commit
bb3335aba2
  1. 228
      src/Transient/Move/Services.hs
  2. 65
      src/Transient/Move/Services/MonitorService.hs

228
src/Transient/Move/Services.hs

@ -17,6 +17,7 @@ module Transient.Move.Services where
import Transient.Base
import Transient.Move
import Transient.Logged(Loggable(..))
import Transient.Backtrack
import Transient.Internals(RemoteStatus(..), Log(..))
import Transient.Move.Utils
@ -33,18 +34,18 @@ import Control.Monad
import Data.List
import Data.Maybe
import Data.Monoid
--import Data.TCache hiding(onNothing)
import Control.Concurrent(threadDelay)
import Control.Exception
import Data.IORef
monitorService= ("https://github.com/agocorona/transient-universe","monitor")
pathExe package program port= {-"./"++package++"/dist/build/"++package++"/"++ -} program
++ " -p start/" ++ show port
install :: String -> String -> Int -> Cloud ()
install package program port = do
exist <- localIO $ findExecutable program -- liftIO $ doesDirectoryExist packagename
let packagename = name package
when (isNothing exist) $ local $ liftIO $ do
install :: String -> String -> String -> Int -> IO ()
install package program host port = do
exist <- findExecutable program -- liftIO $ doesDirectoryExist packagename
when (isNothing exist) $ do
let packagename = name package
when (null packagename) $ error $ "source for \""++package ++ "\" not found"
callProcess "git" ["clone",package]
liftIO $ putStr package >> putStrLn " cloned"
@ -52,12 +53,17 @@ install package program port = do
callProcess "cabal" ["install","--force-reinstalls"]
setCurrentDirectory ".."
return()
let prog = pathExe packagename program port
lliftIO $ print $ "executing "++ prog
localIO $ do createProcess $ shell prog ; return () -- ) <|> return ()
let prog = pathExe program host port
print $ "executing "++ prog
let createprostruct= shell prog
createProcess $ createprostruct ; return ()
threadDelay 2000000
return() -- !> ("INSTALLED", program)
where
pathExe program host port= program ++ " -p start/" ++ show host ++"/" ++ show port
return() -- !> "INSTALLED"
name url= slash . slash . slash $ slash url
where
@ -65,42 +71,40 @@ name url= slash . slash . slash $ slash url
tail1 []=[]
tail1 x= tail x
monitorPort= 3000
rfreePort :: MVar Int
rfreePort = unsafePerformIO $ newMVar 3000
rfreePort = unsafePerformIO $ newMVar (monitorPort +1)
freePort :: MonadIO m => m Int
freePort= liftIO $ modifyMVar rfreePort $ \ n -> return (n+1,n)
initService ident service@(package, program)= loggedc $ do
nodes <- local getNodes
case find (\node -> service `elem` nodeServices node) nodes of
Just node -> return node -- !> "found"
Nothing -> do
node <- runAt (head nodes) $ do
thisNode <- local getMyNode
yn<- requestService ident service
if yn then do
port <- onAll freePort
localIO $ putStr "installing " >> putStrLn package
install package program port
nodeService thisNode port
else empty
local $ addNodes [node]
return node
initService ident service@(package, program)=
(local $ findInNodes service >>= return . head) <|> requestInstall service
where
nodeService (Node h _ _ _) port= localIO $ do
pool <- newMVar []
return $ Node h port pool [service]
requestInstall service = do
mnode <- callService' ident monitorNode (ident,service)
case mnode of
Nothing -> empty
Just node -> do
local $ addNodes [node] -- !> ("ADDNODES",service)
return node
startMonitor= do
createProcess . shell $ "monitorService -p start/"++ show monitorPort
threadDelay 2000000
nodeService (Node h _ _ _) port service= do
pool <- newMVar []
return $ Node h port pool [service]
findInNodes service = do
nodes <- getNodes
let ns = filter (\node -> service `elem` nodeServices node) nodes
if null ns then empty
else return ns
callOne :: Loggable a => Cloud a -> Cloud a
callOne = callNodes after empty
after mx my= waitone mx <|> my
where
waitone mx = local $ do
rs <- collect' 1 1 0 $ runCloud mx
return $ head rs
-- where
--
@ -114,22 +118,64 @@ after mx my= waitone mx <|> my
-- | otherwise = False
rfriends = unsafePerformIO $ newMVar []
rservices = unsafePerformIO $ newMVar []
ridentsBanned = unsafePerformIO $ newMVar []
rServicesBanned = unsafePerformIO $ newMVar []
rfriends = unsafePerformIO $ newIORef ([] ::[String])
rservices = unsafePerformIO $ newIORef ([] ::[Service])
ridentsBanned = unsafePerformIO $ newIORef ([] ::[String])
rServicesBanned = unsafePerformIO $ newIORef ([] ::[Service])
requestService ident service= local $ do
friends <- liftIO $ readMVar rfriends
services <- liftIO $ readMVar rservices
identsBanned <- liftIO $ readMVar ridentsBanned
servicesBanned <- liftIO $ readMVar rServicesBanned
inputAuthorizations= do
oneThread $ option "authorizations" "authorizations"
showPerm <|> friends <|> services <|> identBanned <|> servicesBanned
empty
where
friends= do
option "friends" "friendsss"
fr <- input (const True) "enter the friend list: "
liftIO $ writeIORef rfriends (fr :: [String])
services= do
option "services" "services"
serv <- input (const True) "enter service list: "
liftIO $ writeIORef rservices (serv :: [Service])
identBanned= do
option "bannedIds" "banned users"
ban <- input (const True) "enter the users banned: "
liftIO $ writeIORef ridentsBanned (ban ::[String ])
rs <- liftIO $ readIORef ridentsBanned
liftIO $ print rs
servicesBanned= do
option "bannedServ" "banned services"
ban <- input (const True) "enter the services banned: "
liftIO $ writeIORef rServicesBanned (ban :: [Service])
showPerm= do
option "show" "show permissions"
friends <- liftIO $ readIORef rfriends
services <- liftIO $ readIORef rservices
identsBanned <- liftIO $ readIORef ridentsBanned
servicesBanned <- liftIO $ readIORef rServicesBanned
liftIO $ putStr "allowed: " >> print friends
liftIO $ putStr "banned: " >> print identsBanned
liftIO $ putStr "services allowed: " >> print services
liftIO $ putStr "services banned: " >> print servicesBanned
authorizeService :: MonadIO m => String -> Service -> m Bool
authorizeService ident service= do
friends <- liftIO $ readIORef rfriends
services <- liftIO $ readIORef rservices
identsBanned <- liftIO $ readIORef ridentsBanned
servicesBanned <- liftIO $ readIORef rServicesBanned
return $ if (null friends || ident `elem` friends)
&& (null services || service `elem` services)
&& (null identsBanned || ident `notElem` identsBanned)
&& (null servicesBanned || service `notElem` servicesBanned)
then True else False
then True else False
where
notElem a b= not $ elem a b
@ -138,22 +184,32 @@ callService
:: (Loggable a, Loggable b)
=> String -> Service -> a -> Cloud b
callService ident service params = do
node <- initService ident service -- !> ("callservice initservice", service)
callService' ident node params -- !> ("NODE FOR SERVICE",node)
node <- initService ident service
monitorNode= unsafePerformIO $ createNodeServ "localhost"
(fromIntegral monitorPort)
[monitorService]
callService' ident node params = do
onAll $ onFinish (\me -> do
case fmap fromException me :: Maybe(Maybe IOException) of
Nothing -> return ()
Just (Just e') -> do
noFinish
liftIO startMonitor)
log <- onAll $ do
log <- getSData <|> return emptyLog
setData emptyLog
return log
log <- getSData <|> return emptyLog
setData emptyLog
return log
r <- wormhole node $ loggedc $ do
r <- wormhole node $ do
local $ return params
teleport
local empty
restoreLog log
restoreLog log -- !> "RESTORELOG"
return r
where
@ -188,25 +244,50 @@ runEmbeddedService servname serv = do
runService :: (Loggable a, Loggable b) => Service -> (a -> Cloud b) -> Cloud b
runService servname serv = do
initNodeServ [servname]
wormhole (notused 1) $ loggedc $ do
x <- local $ return $ notused 2
r <- onAll $ runCloud (serv x) <** setData WasRemote
local $ return r
teleport
return r
service
-- onAll inputAuthorizations -- <|> inputNodes
where
service=
wormhole (notused 1) $ do
x <- local $ return $ notused 2
setData emptyLog
r <- local $ runCloud (serv x) <** setData WasRemote
teleport
return r
emptyLog= Log False [] []
notused n= error $ "runService: "++ show (n::Int) ++ " variable should not be used"
initNodeServ servs=do
mynode <- local $ do
port <- getPort
liftIO $ createNodeServ "localhost" port servs
mynode <- local getNode
listen mynode -- <|> return()
local $ do
conn <- defConnection
setData conn{myNode = mynode}
onAll inputAuthorizations <|> (inputNodes >> empty) <|> return ()
listen mynode
where
getPort :: TransIO Integer
getPort = if isBrowserInstance then return 0 else do
getNode :: TransIO Node
getNode = if isBrowserInstance then liftIO createWebNode else do
oneThread $ option "start" "re/start node"
input (const True) "port to listen? "
host <- input (const True) "hostname of this node (must be reachable): "
port <- input (const True) "port to listen? "
liftIO $ createNodeServ host port servs
inputNodes= do
onServer $ do
local $ option "add" "add a new monitor node"
host <- local $ do
r <- input (const True) "Host to connect to: (none): "
if r == "" then stop else return r
port <- local $ input (const True) "port? "
nnode <- localIO $ createNodeServ host port [monitorService]
local $ do
liftIO $ putStr "Added node: ">> print nnode
addNodes [nnode]
empty
{- |
a service called monitor:
@ -218,9 +299,8 @@ a service called monitor:
execute
return node
-}
--localServiceMonitor ident service = keep $ runCloud $
-- runService ("https://github.com/agocorona/transient-universe","monitor") $ do
-- initService ident service

65
src/Transient/Move/Services/MonitorService.hs

@ -0,0 +1,65 @@
-----------------------------------------------------------------------------
--
-- Module : Transient.Move.Services.MonitorService
-- Copyright :
-- License : MIT
--
-- Maintainer : agocorona@gmail.com
-- Stability :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
module Main where
import Transient.Base
import Transient.Move
import Transient.Move.Utils
import Transient.Move.Services
import Control.Applicative
import Control.Monad.IO.Class
import Data.List ((\\))
main = keep . runCloud $ do
runService monitorService $ \(ident,service) -> do
mnode <- (local $ findInNodes service >>= return . Just . head) <|>
requestInstall ident service
return (mnode :: Maybe Node)
where
installHere ident service@(package,program)= local $ do
thisNode <- getMyNode
yn<- authorizeService ident service -- !> "AUTHORIZE"
if yn
then do
node <- liftIO $ do
port <- freePort
putStr "Monitor: installing " >> putStrLn package
install package program (nodeHost thisNode) port
putStrLn "INSTALLED"
nodeService thisNode port service
addNodes [node]
return $ Just node
else return Nothing
requestInstall :: String -> Service -> Cloud (Maybe Node)
requestInstall ident service= do
mnode <- installHere ident service -- !> "INSTALLHERE"
case mnode of
Nothing -> installThere ident service
justnode -> return justnode
installThere ident service= do
nodes <- onAll $ findInNodes monitorService -- !> "installThere"
mynode <- onAll getMyNode -- !> nodes
request $ nodes \\ [mynode]
where
request []= empty
request (n:ns)= do
mnode <- callService' ident n (ident,service) -- !> ("calling",n)
case mnode of
Nothing -> request ns
justnode -> return justnode
Loading…
Cancel
Save