AERN-Net-0.2.0: src/Control/ERNet/Deployment/Local/Manager.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-|
    Module      :  Control.ERNet.Deployment.Local.Manager
    Description :  manager implementation using local threads and STM 
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mik@konecny.aow.cz
    Stability   :  experimental
    Portability :  portable

    A simple implementation of 
    "Control.ERNet.Foundations.Manager.Manager",
    deploying all processes locally.

-}

module Control.ERNet.Deployment.Local.Manager 
(
    ManagerLocal()
)
where

import Control.ERNet.Deployment.Local.Logger
import Control.ERNet.Deployment.Local.Channel

import Control.ERNet.Foundations.Protocol
import Control.ERNet.Foundations.Event
import qualified Control.ERNet.Foundations.Event.Logger as LG
import qualified Control.ERNet.Foundations.Channel as CH
import Control.ERNet.Foundations.Process
import Control.ERNet.Foundations.Manager

import Control.Concurrent as Concurrent

import qualified Data.Map as Map

newtype ManagerLocal =
    ManagerLocal ManagerName
    
instance 
    Manager 
        ManagerLocal LoggerLocal 
        ChannelLocal ChannelLocal 
        ChannelLocalAnyProt ChannelLocalAnyProt
    where
    new name =
        do
        putStrLn $ "simulating the creation of network manager " ++ name
        return (ManagerLocal name, "ernet-local:/" ++ name)
    connectNeighbour (ManagerLocal name) neighbourID =
        do
        putStrLn $ 
            "simulating the connection of neighbour " 
            ++ neighbourID ++ " to the manager " ++ name
        return True
    runProcess (ManagerLocal name) process =
        do
        logger <- LG.new
        forkIO $ (erprocDeploy process) (erprocName process) [] [] (startNet logger)
        return logger
        
startNet 
        logger 
        locationDescr
        [] _ processesMappings =
    do
    deployProcesses logger locationDescr "" [] [] processesMappings
    return ()

startNet _ _ _ _ _ = 
    error $ 
        "Control.ERNet.Deployment.ManagerLocal: startNet: Illegal attempt to kick-start a network: outermost network cannot have input sockets" 

expandProcess 
        logger processNamePrefix inCHAs outCHAs -- these 4 provided by manager
        locationDescr inputTypesNames outputTypesNames processesMappings =
    do
    dispatcher Nothing
    where
    (outChTs, outChNs) = unzip outputTypesNames
    (inChTs, inChNs) = unzip inputTypesNames
    
    dispatcher maybeN2channel =
        do
        -- wait for a query:
--        putStrLn $ "ERProcessNet: " ++ defName ++ ": waiting for a query on " ++ show (length resCHAs) ++ " channels" 
        (chN, qryData) <- CH.waitForQueryMulti outCHAs
--        putStrLn $ "ERProcessNet: " ++ defName ++ ": forwarding query on channel " ++ show chN 
        n2channel <- -- number |-> internal or input channel
            case maybeN2channel of
                Nothing -> -- the first query -> plumb the subnet
                    deployProcesses 
                        logger locationDescr processNamePrefix 
                        inCHAs inChNs processesMappings 
                Just n2channel -> return n2channel
        -- pass on the query to the subnet:
        let fwdCHA = fst $ n2channel $ outChNs !! chN
        let outCHA = outCHAs !! chN
        let chT = outChTs !! chN
        forkIO $ forwardQueryAnswer outCHA fwdCHA chT qryData
        dispatcher (Just n2channel)
        
    forwardQueryAnswer causeCHA fwdCHA chT (causeQryId, qryAnyProt) =
        do
        argQryId <- 
            CH.makeQueryAnyProt locationDescr causeCHA causeQryId fwdCHA qryAnyProt
        -- wait for answer from inside:
        (_, ansAnyProt) <- CH.waitForAnswerMulti causeCHA causeQryId [(fwdCHA, argQryId)]
        -- forward the answer out:
        CH.answerQueryAnyProt locationDescr False causeCHA (causeQryId, ansAnyProt)

deployProcesses :: 
    (CH.ChannelForScheduler lg sIn sOut sInAnyProt sOutAnyProt) =>
    lg -> 
    String -> 
    String -> 
    [sInAnyProt] -> 
    [Int] -> 
    [(ERProcess sInAnyProt sOutAnyProt, ([Int], [Int]))] -> 
    IO (Int -> (sInAnyProt, sOutAnyProt))
deployProcesses logger locationDescr namePrefix inCHAs inChNs processesMappings =
    do
    -- create required internal channels:
    internalCHAs <- 
        mapM makeNewChannel internalTypesNamesProcesses
    let n2channel = makeChannelMap internalCHAs
    -- deploy all internal processes:
    mapM (deployProcess n2channel) $ processesMappings
    return n2channel
    where
    makeNewChannel (((chN, chT), (procName, outChN))) =
        CH.new logger (namePrefix ++ procName) outChN chT
    internalTypesNamesProcesses = 
        concat $ map getProcessChanTypesNames processesMappings
        where
        getProcessChanTypesNames (process, (inNs, outNs)) = 
            (zip (zip outNs (erprocOutputTypes process)) $ 
                zip (repeat $ erprocName process) [0..])
    makeChannelMap internalCHAs n =
        case Map.lookup n n2chMap of
             Nothing -> 
                error $ locationDescr ++ " deployProcess: unknown channel number: " ++ show n
             Just ch -> ch
        where
        n2chMap = 
            Map.fromList $ 
                (zip internalChNs internalCHAs) ++ 
                (zip inChNs $ zip inCHAs (repeat errorOUT))
        errorOUT = 
            error "ManagerLocal: makeChannelMap: input channel treated as output channel"
    internalChNs = 
        concat $ map (snd . snd) processesMappings
    deployProcess n2channel (process, (processInChNs, processOutChNs)) =
        do
        forkIO $ 
            (erprocDeploy process) 
                name
                processInCHAs processOutCHAs
                (expandProcess logger (name ++ ".") processInCHAs processOutCHAs)
        where
        name = namePrefix ++ erprocName process
        processInCHAs = map (fst . n2channel) processInChNs
        processOutCHAs = map (snd . n2channel) processOutChNs