-----------------------------------------------------------------------------
--
-- Module : Transient.Move.Services
-- Copyright :
-- License : GPL-3
--
-- Maintainer : agocorona@gmail.com
-- Stability :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
module Transient.Move.Services where
import Transient.Base
import Transient.Move
import Transient.Logged(Loggable(..))
--import Transient.Internals((!>))
import Transient.Move.Utils
import Transient.Internals(Log(..))
import Transient.EVars
import Transient.Indeterminism
import Control.Monad.IO.Class
import System.Process
import System.IO.Unsafe
import Control.Concurrent.MVar
import Control.Applicative
import System.Directory
import Control.Monad
import Data.List
import Data.Maybe
--import Data.TCache hiding(onNothing)
-- for the example
import System.Environment
--startServices :: Cloud ()
--startServices= local $ do
-- node <- getMyNode
-- liftIO $ print node
-- let servs = nodeServices node
-- mapM_ start servs
-- where
-- start (package,program)= liftIO $ do
-- let prog= pathExe (name package) program port
-- liftIO $ print prog
-- createProcess $ shell prog
pathExe package program port= package++"/dist/build/"++package++"/"++program
++ " -p start/" ++ show port
install :: String -> String -> Int -> Cloud ()
install package program port = do
let packagename = name package
when (null packagename) $ error $ "source for \""++package ++ "\" not found"
exist <- local $ liftIO $ doesDirectoryExist packagename
when (not exist) $ local $ liftIO $ do
callProcess "git" ["clone",package]
liftIO $ print "GIT DONE"
setCurrentDirectory packagename
callProcess "cabal" ["install","--force-reinstalls"]
setCurrentDirectory ".."
return()
let prog = pathExe packagename program port
lliftIO $ print prog
local $ liftIO $ do
createProcess $ shell program
return ()
return()
name url= slash . slash . slash $ slash url
where
slash= tail1 . dropWhile (/='/')
tail1 []=[]
tail1 x= tail x
rfreePort :: MVar Int
rfreePort = unsafePerformIO $ newMVar 3000
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
Nothing -> do
nodes <- callOne $ do
yn<- requestService ident service
if yn then do
port <- onAll freePort
install package program port
nodeService port
else empty
local $ addNodes nodes
return $ head nodes
where
nodeService port= local $ do
Node h _ _ _ <- getMyNode
return $ Node h port (unsafePerformIO $ newMVar []) [service] :: TransIO Node
callOne mx= local . collect 1 . runCloud $ clustered mx
rfriends = unsafePerformIO $ newMVar []
rservices = unsafePerformIO $ newMVar []
ridentsBanned = unsafePerformIO $ newMVar []
rServicesBanned = unsafePerformIO $ newMVar []
requestService ident service= local $ do
friends <- liftIO $ readMVar rfriends
services <- liftIO $ readMVar rservices
identsBanned <- liftIO $ readMVar ridentsBanned
servicesBanned <- liftIO $ readMVar 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
where
notElem a b= not $ elem a b
callService
:: (Loggable a, Loggable b)
=> String -> Service -> a -> Cloud b
callService ident service params = do
node <- initService ident service
log <- onAll $ do
log <- getSData <|> return emptyLog
setData emptyLog
return log
r <- wormhole node $ loggedc $ do
local $ return params
teleport
local empty
-- return () !> ("r=",r)
restoreLog log
-- local $ do
-- Log _ _ log <- getSData <|> return emptyLog
-- return() !> ("log after",log)
return r -- (r `asTypeOf` witness)
where
restoreLog (Log _ _ logw)= onAll $ do
Log _ _ logw' <- getSData <|> return emptyLog
let newlog= reverse logw' ++ logw
-- return () !> ("newlog", logw,logw')
setData $ Log False newlog newlog
emptyLog= Log False [] []
{-
servicios
autoinstall service
servicio de instalaci¢n de servicios
procedurers call services, services install themselves in nodes.
clustered oriented call invoke the nodes that shares the same service.
if the service variable state is set. if not, invoke all the nodes.
some service accessing data may move to the machine where the data is if support the service.
servicio en browser necesita algo que en el server no existe y no pude dar:
forward the request to other nodes
return the result to the browser.
forward service requests:
cuando un nodo no puede servir un servicio, puede hacer forward.
otros nodos puede instalarlo o hacer forward a su vez
clusterizaci¢n de servicios
nodo con database saturado puede hacer automatic sharding
siquientes requests retornan los nuevos nodos
la resupuesta de un servicio puede incluir una nueva direcci¢n, del nodo donde se ha movido o donde ha delegado.
servicio wrarpper que ejecuta una libreria no transient
cat logo de servicios
ghcjsi service for notebooks
web site de compilaci¢n que compile en su propio ordenador
opcion descargar el programa de instalacion y hace stack build
ventaja: conectar todos los nodos que ejecutan un servicio determinado
necesario un deposito de nombres de servicios:: github
friend ident.... request you to install... in your computer. Do you agree?
if ident is the same, this is automatic.
-}