{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
-- | Used for management of applications.
module Keter.AppManager
    ( -- * Types
      AppManager
    , Action (..)
      -- * Actions
    , perform
    , reloadAppList
    , addApp
    , terminateApp
      -- * Initialize
    , initialize
    ) where

import           Control.Applicative
import           Control.Concurrent        (forkIO)
import           Control.Concurrent.MVar   (MVar, newMVar, withMVar)
import           Control.Concurrent.STM
import qualified Control.Exception         as E
import           Control.Monad             (void)
import qualified Data.Map                  as Map
import           Data.Maybe                (mapMaybe)
import           Data.Maybe                (catMaybes)
import qualified Data.Set                  as Set
import           Keter.App                 (App, AppStartConfig)
import qualified Keter.App                 as App
import           Keter.Types
import           Prelude                   hiding (FilePath, log)
import           System.Posix.Files        (getFileStatus, modificationTime)
import           System.Posix.Types        (EpochTime)

data AppManager = AppManager
    { AppManager -> TVar (Map AppId (TVar AppState))
apps           :: !(TVar (Map AppId (TVar AppState)))
    , AppManager -> AppStartConfig
appStartConfig :: !AppStartConfig
    , AppManager -> MVar ()
mutex          :: !(MVar ())
    , AppManager -> LogMessage -> IO ()
log            :: !(LogMessage -> IO ())
    }

data AppState = ASRunning App
              | ASStarting
                    !(Maybe App)
                    !(TVar (Maybe EpochTime))
                    !(TVar (Maybe Action)) -- ^ the next one to try
              | ASTerminated

data Action = Reload AppInput | Terminate

initialize :: (LogMessage -> IO ())
           -> AppStartConfig
           -> IO AppManager
initialize :: (LogMessage -> IO ()) -> AppStartConfig -> IO AppManager
initialize LogMessage -> IO ()
log' AppStartConfig
asc = TVar (Map AppId (TVar AppState))
-> AppStartConfig -> MVar () -> (LogMessage -> IO ()) -> AppManager
AppManager
    (TVar (Map AppId (TVar AppState))
 -> AppStartConfig
 -> MVar ()
 -> (LogMessage -> IO ())
 -> AppManager)
-> IO (TVar (Map AppId (TVar AppState)))
-> IO
     (AppStartConfig -> MVar () -> (LogMessage -> IO ()) -> AppManager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map AppId (TVar AppState) -> IO (TVar (Map AppId (TVar AppState)))
forall a. a -> IO (TVar a)
newTVarIO Map AppId (TVar AppState)
forall k a. Map k a
Map.empty
    IO
  (AppStartConfig -> MVar () -> (LogMessage -> IO ()) -> AppManager)
-> IO AppStartConfig
-> IO (MVar () -> (LogMessage -> IO ()) -> AppManager)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AppStartConfig -> IO AppStartConfig
forall (m :: * -> *) a. Monad m => a -> m a
return AppStartConfig
asc
    IO (MVar () -> (LogMessage -> IO ()) -> AppManager)
-> IO (MVar ()) -> IO ((LogMessage -> IO ()) -> AppManager)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    IO ((LogMessage -> IO ()) -> AppManager)
-> IO (LogMessage -> IO ()) -> IO AppManager
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LogMessage -> IO ()) -> IO (LogMessage -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return LogMessage -> IO ()
log'

-- | Reset which apps are running.
--
-- * Any app not listed here that is currently running will be terminated.
--
-- * Any app listed here that is currently running will be reloaded.
--
-- * Any app listed here that is not currently running will be started.
reloadAppList :: AppManager
              -> Map Appname (FilePath, EpochTime)
              -> IO ()
reloadAppList :: AppManager -> Map Appname (FilePath, EpochTime) -> IO ()
reloadAppList am :: AppManager
am@AppManager {TVar (Map AppId (TVar AppState))
MVar ()
AppStartConfig
LogMessage -> IO ()
log :: LogMessage -> IO ()
mutex :: MVar ()
appStartConfig :: AppStartConfig
apps :: TVar (Map AppId (TVar AppState))
log :: AppManager -> LogMessage -> IO ()
mutex :: AppManager -> MVar ()
appStartConfig :: AppManager -> AppStartConfig
apps :: AppManager -> TVar (Map AppId (TVar AppState))
..} Map Appname (FilePath, EpochTime)
newApps = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
mutex ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [IO ()]
actions <- STM [IO ()] -> IO [IO ()]
forall a. STM a -> IO a
atomically (STM [IO ()] -> IO [IO ()]) -> STM [IO ()] -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ do
        Map AppId (TVar AppState)
m <- TVar (Map AppId (TVar AppState)) -> STM (Map AppId (TVar AppState))
forall a. TVar a -> STM a
readTVar TVar (Map AppId (TVar AppState))
apps
        let currentApps :: Set Appname
currentApps = [Appname] -> Set Appname
forall a. Ord a => [a] -> Set a
Set.fromList ([Appname] -> Set Appname) -> [Appname] -> Set Appname
forall a b. (a -> b) -> a -> b
$ (AppId -> Maybe Appname) -> [AppId] -> [Appname]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AppId -> Maybe Appname
toAppName ([AppId] -> [Appname]) -> [AppId] -> [Appname]
forall a b. (a -> b) -> a -> b
$ Map AppId (TVar AppState) -> [AppId]
forall k a. Map k a -> [k]
Map.keys Map AppId (TVar AppState)
m
            allApps :: [Appname]
allApps = Set Appname -> [Appname]
forall a. Set a -> [a]
Set.toList (Set Appname -> [Appname]) -> Set Appname -> [Appname]
forall a b. (a -> b) -> a -> b
$ Map Appname (FilePath, EpochTime) -> Set Appname
forall k a. Map k a -> Set k
Map.keysSet Map Appname (FilePath, EpochTime)
newApps Set Appname -> Set Appname -> Set Appname
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Appname
currentApps
        ([Maybe (IO ())] -> [IO ()]) -> STM [Maybe (IO ())] -> STM [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (IO ())] -> [IO ()]
forall a. [Maybe a] -> [a]
catMaybes (STM [Maybe (IO ())] -> STM [IO ()])
-> STM [Maybe (IO ())] -> STM [IO ()]
forall a b. (a -> b) -> a -> b
$ (Appname -> STM (Maybe (IO ())))
-> [Appname] -> STM [Maybe (IO ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Map AppId (TVar AppState) -> Appname -> STM (Maybe (IO ()))
getAction Map AppId (TVar AppState)
m) [Appname]
allApps
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
actions
  where
    toAppName :: AppId -> Maybe Appname
toAppName AppId
AIBuiltin = Maybe Appname
forall a. Maybe a
Nothing
    toAppName (AINamed Appname
x) = Appname -> Maybe Appname
forall a. a -> Maybe a
Just Appname
x

    getAction :: Map AppId (TVar AppState) -> Appname -> STM (Maybe (IO ()))
getAction Map AppId (TVar AppState)
currentApps Appname
appname = do
        case AppId -> Map AppId (TVar AppState) -> Maybe (TVar AppState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Appname -> AppId
AINamed Appname
appname) Map AppId (TVar AppState)
currentApps of
            Maybe (TVar AppState)
Nothing -> Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
freshLaunch
            Just TVar AppState
tstate -> do
                AppState
state <- TVar AppState -> STM AppState
forall a. TVar a -> STM a
readTVar TVar AppState
tstate
                case AppState
state of
                    AppState
ASTerminated -> Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
freshLaunch
                    ASRunning App
app ->
                        case Appname
-> Map Appname (FilePath, EpochTime) -> Maybe (FilePath, EpochTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Appname
appname Map Appname (FilePath, EpochTime)
newApps of
                            Maybe (FilePath, EpochTime)
Nothing -> Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
terminate
                            Just (FilePath
fp, EpochTime
newTimestamp) -> do
                                Maybe EpochTime
moldTimestamp <- App -> STM (Maybe EpochTime)
App.getTimestamp App
app
                                Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO ()) -> STM (Maybe (IO ())))
-> Maybe (IO ()) -> STM (Maybe (IO ()))
forall a b. (a -> b) -> a -> b
$ if Maybe EpochTime
moldTimestamp Maybe EpochTime -> Maybe EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
== EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
newTimestamp
                                    then Maybe (IO ())
forall a. Maybe a
Nothing
                                    else FilePath -> EpochTime -> Maybe (IO ())
reload FilePath
fp EpochTime
newTimestamp
                    ASStarting Maybe App
_ TVar (Maybe EpochTime)
tmoldTimestamp TVar (Maybe Action)
tmaction ->
                        case Appname
-> Map Appname (FilePath, EpochTime) -> Maybe (FilePath, EpochTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Appname
appname Map Appname (FilePath, EpochTime)
newApps of
                            Maybe (FilePath, EpochTime)
Nothing -> do
                                TVar (Maybe Action) -> Maybe Action -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Action)
tmaction (Maybe Action -> STM ()) -> Maybe Action -> STM ()
forall a b. (a -> b) -> a -> b
$ Action -> Maybe Action
forall a. a -> Maybe a
Just Action
Terminate
                                Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
forall a. Maybe a
Nothing
                            Just (FilePath
fp, EpochTime
newTimestamp) -> do
                                Maybe EpochTime
moldTimestamp <- TVar (Maybe EpochTime) -> STM (Maybe EpochTime)
forall a. TVar a -> STM a
readTVar TVar (Maybe EpochTime)
tmoldTimestamp
                                Maybe (IO ()) -> STM (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO ()) -> STM (Maybe (IO ())))
-> Maybe (IO ()) -> STM (Maybe (IO ()))
forall a b. (a -> b) -> a -> b
$ if Maybe EpochTime
moldTimestamp Maybe EpochTime -> Maybe EpochTime -> Bool
forall a. Eq a => a -> a -> Bool
== EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
newTimestamp
                                    then Maybe (IO ())
forall a. Maybe a
Nothing
                                    else FilePath -> EpochTime -> Maybe (IO ())
reload FilePath
fp EpochTime
newTimestamp
      where
        freshLaunch :: Maybe (IO ())
freshLaunch =
            case Appname
-> Map Appname (FilePath, EpochTime) -> Maybe (FilePath, EpochTime)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Appname
appname Map Appname (FilePath, EpochTime)
newApps of
                Maybe (FilePath, EpochTime)
Nothing -> Bool -> Maybe (IO ()) -> Maybe (IO ())
forall a. (?callStack::CallStack) => Bool -> a -> a
E.assert Bool
False Maybe (IO ())
forall a. Maybe a
Nothing
                Just (FilePath
fp, EpochTime
timestamp) -> FilePath -> EpochTime -> Maybe (IO ())
reload FilePath
fp EpochTime
timestamp
        terminate :: Maybe (IO ())
terminate = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager -> AppId -> Action -> IO ()
performNoLock AppManager
am (Appname -> AppId
AINamed Appname
appname) Action
Terminate
        reload :: FilePath -> EpochTime -> Maybe (IO ())
reload FilePath
fp EpochTime
timestamp = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager -> AppId -> Action -> IO ()
performNoLock AppManager
am (Appname -> AppId
AINamed Appname
appname) (AppInput -> Action
Reload (AppInput -> Action) -> AppInput -> Action
forall a b. (a -> b) -> a -> b
$ FilePath -> EpochTime -> AppInput
AIBundle FilePath
fp EpochTime
timestamp)
        {-
        case (Map.lookup appname currentApps, Map.lookup appname newApps) of
            (Nothing, Nothing) -> E.assert False Nothing
            (Just _, Nothing) -> Just $ perform am (AINamed appname) Terminate
            (Nothing, Just _) -> Just $ perform am (AINamed appname) (Reload AIBundle)
            -}

    {- FIXME
        actions <- do

            current <- getAllApps appMan
            let apps = Set.toList $ Set.fromList (Map.keys newMap) `Set.union` current
            fmap catMaybes $ forM apps $ \appname -> return $
                case (Set.member appname current, Map.lookup appname newMap) of
                    (False, Nothing) -> Nothing -- should never happen
                    (True, Nothing) -> Just $ terminateApp appname
                    (False, Just (bundle, _)) -> Just $ runKIO' $ addApp bundle
                    (Just (_, oldTime), Just (bundle, newTime))
                        | newTime /= oldTime -> Just $ runKIO' $ addApp bundle
                        | otherwise -> Nothing
        P.sequence_ actions

getAllApps :: AppManager -> IO (Set Appname)
getAllApps AppManager {..} = atomically $ do
    m <- readTVar apps
    return $ Set.fromList $ mapMaybe toAppName $ Map.keys m
    -}

perform :: AppManager -> AppId -> Action -> IO ()
perform :: AppManager -> AppId -> Action -> IO ()
perform AppManager
am AppId
appid Action
action = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (AppManager -> MVar ()
mutex AppManager
am) ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppManager -> AppId -> Action -> IO ()
performNoLock AppManager
am AppId
appid Action
action

performNoLock :: AppManager -> AppId -> Action -> IO ()
performNoLock :: AppManager -> AppId -> Action -> IO ()
performNoLock am :: AppManager
am@AppManager {TVar (Map AppId (TVar AppState))
MVar ()
AppStartConfig
LogMessage -> IO ()
log :: LogMessage -> IO ()
mutex :: MVar ()
appStartConfig :: AppStartConfig
apps :: TVar (Map AppId (TVar AppState))
log :: AppManager -> LogMessage -> IO ()
mutex :: AppManager -> MVar ()
appStartConfig :: AppManager -> AppStartConfig
apps :: AppManager -> TVar (Map AppId (TVar AppState))
..} AppId
aid Action
action = IO () -> IO ()
forall a. IO a -> IO a
E.mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO ()
launchWorker' <- STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
        Map AppId (TVar AppState)
m <- TVar (Map AppId (TVar AppState)) -> STM (Map AppId (TVar AppState))
forall a. TVar a -> STM a
readTVar TVar (Map AppId (TVar AppState))
apps
        case AppId -> Map AppId (TVar AppState) -> Maybe (TVar AppState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AppId
aid Map AppId (TVar AppState)
m of
            Just TVar AppState
tstate -> do
                AppState
state <- TVar AppState -> STM AppState
forall a. TVar a -> STM a
readTVar TVar AppState
tstate
                case AppState
state of
                    ASStarting Maybe App
_mcurrent TVar (Maybe EpochTime)
_tmtimestamp TVar (Maybe Action)
tmnext -> do
                        TVar (Maybe Action) -> Maybe Action -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Action)
tmnext (Maybe Action -> STM ()) -> Maybe Action -> STM ()
forall a b. (a -> b) -> a -> b
$ Action -> Maybe Action
forall a. a -> Maybe a
Just Action
action
                        -- use the previous worker, so nothing to do
                        IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
noWorker
                    ASRunning App
runningApp -> do
                        TVar (Maybe Action)
tmnext <- Maybe Action -> STM (TVar (Maybe Action))
forall a. a -> STM (TVar a)
newTVar Maybe Action
forall a. Maybe a
Nothing
                        TVar (Maybe EpochTime)
tmtimestamp <- Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a. a -> STM (TVar a)
newTVar (Maybe EpochTime -> STM (TVar (Maybe EpochTime)))
-> Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a b. (a -> b) -> a -> b
$
                            case Action
action of
                                Reload (AIBundle FilePath
_fp EpochTime
timestamp) -> EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
timestamp
                                Reload (AIData BundleConfig
_) -> Maybe EpochTime
forall a. Maybe a
Nothing
                                Action
Terminate -> Maybe EpochTime
forall a. Maybe a
Nothing
                        TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate (AppState -> STM ()) -> AppState -> STM ()
forall a b. (a -> b) -> a -> b
$ Maybe App
-> TVar (Maybe EpochTime) -> TVar (Maybe Action) -> AppState
ASStarting (App -> Maybe App
forall a. a -> Maybe a
Just App
runningApp) TVar (Maybe EpochTime)
tmtimestamp TVar (Maybe Action)
tmnext
                        IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager
-> AppId
-> TVar AppState
-> TVar (Maybe Action)
-> Maybe App
-> Action
-> IO ()
launchWorker AppManager
am AppId
aid TVar AppState
tstate TVar (Maybe Action)
tmnext (App -> Maybe App
forall a. a -> Maybe a
Just App
runningApp) Action
action
                    AppState
ASTerminated -> STM (IO ())
onNotRunning
            Maybe (TVar AppState)
Nothing -> STM (IO ())
onNotRunning
    IO ()
launchWorker'
  where
    noWorker :: IO ()
noWorker = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    onNotRunning :: STM (IO ())
onNotRunning =
        case Action
action of
            Reload AppInput
input -> do
                TVar (Maybe Action)
tmnext <- Maybe Action -> STM (TVar (Maybe Action))
forall a. a -> STM (TVar a)
newTVar Maybe Action
forall a. Maybe a
Nothing
                TVar (Maybe EpochTime)
tmtimestamp <- Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a. a -> STM (TVar a)
newTVar (Maybe EpochTime -> STM (TVar (Maybe EpochTime)))
-> Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a b. (a -> b) -> a -> b
$
                    case AppInput
input of
                        AIBundle FilePath
_fp EpochTime
timestamp -> EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
timestamp
                        AIData BundleConfig
_ -> Maybe EpochTime
forall a. Maybe a
Nothing
                TVar AppState
tstate <- AppState -> STM (TVar AppState)
forall a. a -> STM (TVar a)
newTVar (AppState -> STM (TVar AppState))
-> AppState -> STM (TVar AppState)
forall a b. (a -> b) -> a -> b
$ Maybe App
-> TVar (Maybe EpochTime) -> TVar (Maybe Action) -> AppState
ASStarting Maybe App
forall a. Maybe a
Nothing TVar (Maybe EpochTime)
tmtimestamp TVar (Maybe Action)
tmnext
                TVar (Map AppId (TVar AppState))
-> (Map AppId (TVar AppState) -> Map AppId (TVar AppState))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map AppId (TVar AppState))
apps ((Map AppId (TVar AppState) -> Map AppId (TVar AppState))
 -> STM ())
-> (Map AppId (TVar AppState) -> Map AppId (TVar AppState))
-> STM ()
forall a b. (a -> b) -> a -> b
$ AppId
-> TVar AppState
-> Map AppId (TVar AppState)
-> Map AppId (TVar AppState)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AppId
aid TVar AppState
tstate
                IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ AppManager
-> AppId
-> TVar AppState
-> TVar (Maybe Action)
-> Maybe App
-> Action
-> IO ()
launchWorker AppManager
am AppId
aid TVar AppState
tstate TVar (Maybe Action)
tmnext Maybe App
forall a. Maybe a
Nothing Action
action
            Action
Terminate -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
noWorker

launchWorker :: AppManager
             -> AppId
             -> TVar AppState
             -> TVar (Maybe Action)
             -> Maybe App
             -> Action
             -> IO ()
launchWorker :: AppManager
-> AppId
-> TVar AppState
-> TVar (Maybe Action)
-> Maybe App
-> Action
-> IO ()
launchWorker AppManager {TVar (Map AppId (TVar AppState))
MVar ()
AppStartConfig
LogMessage -> IO ()
log :: LogMessage -> IO ()
mutex :: MVar ()
appStartConfig :: AppStartConfig
apps :: TVar (Map AppId (TVar AppState))
log :: AppManager -> LogMessage -> IO ()
mutex :: AppManager -> MVar ()
appStartConfig :: AppManager -> AppStartConfig
apps :: AppManager -> TVar (Map AppId (TVar AppState))
..} AppId
appid TVar AppState
tstate TVar (Maybe Action)
tmnext Maybe App
mcurrentApp0 Action
action0 = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Maybe App -> Action -> IO ()
loop Maybe App
mcurrentApp0 Action
action0
  where
    loop :: Maybe App -> Action -> IO ()
loop Maybe App
mcurrentApp Action
action = do
        Maybe App
mRunningApp <- Maybe App -> Action -> IO (Maybe App)
processAction Maybe App
mcurrentApp Action
action
        Maybe Action
mnext <- STM (Maybe Action) -> IO (Maybe Action)
forall a. STM a -> IO a
atomically (STM (Maybe Action) -> IO (Maybe Action))
-> STM (Maybe Action) -> IO (Maybe Action)
forall a b. (a -> b) -> a -> b
$ do
            Maybe Action
mnext <- TVar (Maybe Action) -> STM (Maybe Action)
forall a. TVar a -> STM a
readTVar TVar (Maybe Action)
tmnext
            TVar (Maybe Action) -> Maybe Action -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe Action)
tmnext Maybe Action
forall a. Maybe a
Nothing
            case Maybe Action
mnext of
                Maybe Action
Nothing ->
                    case Maybe App
mRunningApp of
                        Maybe App
Nothing -> TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate AppState
ASTerminated
                        Just App
runningApp -> TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate (AppState -> STM ()) -> AppState -> STM ()
forall a b. (a -> b) -> a -> b
$ App -> AppState
ASRunning App
runningApp
                Just Action
_next -> do
                    TVar (Maybe EpochTime)
tmtimestamp <- Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a. a -> STM (TVar a)
newTVar (Maybe EpochTime -> STM (TVar (Maybe EpochTime)))
-> Maybe EpochTime -> STM (TVar (Maybe EpochTime))
forall a b. (a -> b) -> a -> b
$
                        case Action
action of
                            Reload (AIBundle FilePath
_fp EpochTime
timestamp) -> EpochTime -> Maybe EpochTime
forall a. a -> Maybe a
Just EpochTime
timestamp
                            Reload (AIData BundleConfig
_) -> Maybe EpochTime
forall a. Maybe a
Nothing
                            Action
Terminate -> Maybe EpochTime
forall a. Maybe a
Nothing
                    TVar AppState -> AppState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar AppState
tstate (AppState -> STM ()) -> AppState -> STM ()
forall a b. (a -> b) -> a -> b
$ Maybe App
-> TVar (Maybe EpochTime) -> TVar (Maybe Action) -> AppState
ASStarting Maybe App
mRunningApp TVar (Maybe EpochTime)
tmtimestamp TVar (Maybe Action)
tmnext
            Maybe Action -> STM (Maybe Action)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Action
mnext
        case Maybe Action
mnext of
            Maybe Action
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Action
next -> Maybe App -> Action -> IO ()
loop Maybe App
mRunningApp Action
next

    processAction :: Maybe App -> Action -> IO (Maybe App)
processAction Maybe App
Nothing Action
Terminate = Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe App
forall a. Maybe a
Nothing
    processAction (Just App
app) Action
Terminate = do
        LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> LogMessage
Terminating (FilePath -> LogMessage) -> FilePath -> LogMessage
forall a b. (a -> b) -> a -> b
$ App -> FilePath
forall a. Show a => a -> FilePath
show App
app
        App -> IO ()
App.terminate App
app
        Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe App
forall a. Maybe a
Nothing
    processAction Maybe App
Nothing (Reload AppInput
input) = do
        LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> FilePath -> LogMessage
ReloadFrom Maybe FilePath
forall a. Maybe a
Nothing (FilePath -> LogMessage) -> FilePath -> LogMessage
forall a b. (a -> b) -> a -> b
$ AppInput -> FilePath
forall a. Show a => a -> FilePath
show AppInput
input
        Either SomeException App
eres <- IO App -> IO (Either SomeException App)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO App -> IO (Either SomeException App))
-> IO App -> IO (Either SomeException App)
forall a b. (a -> b) -> a -> b
$ AppStartConfig -> AppId -> AppInput -> IO App
App.start AppStartConfig
appStartConfig AppId
appid AppInput
input
        case Either SomeException App
eres of
            Left SomeException
e -> do
                LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Appname -> SomeException -> LogMessage
ErrorStartingBundle Appname
name SomeException
e
                Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe App
forall a. Maybe a
Nothing
            Right App
app -> Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe App -> IO (Maybe App)) -> Maybe App -> IO (Maybe App)
forall a b. (a -> b) -> a -> b
$ App -> Maybe App
forall a. a -> Maybe a
Just App
app
    processAction (Just App
app) (Reload AppInput
input) = do
        LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> FilePath -> LogMessage
ReloadFrom (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ App -> FilePath
forall a. Show a => a -> FilePath
show App
app) (AppInput -> FilePath
forall a. Show a => a -> FilePath
show AppInput
input)
        Either SomeException ()
eres <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ App -> AppInput -> IO ()
App.reload App
app AppInput
input
        case Either SomeException ()
eres of
            Left SomeException
e -> do
                LogMessage -> IO ()
log (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Appname -> SomeException -> LogMessage
ErrorStartingBundle Appname
name SomeException
e
                -- reloading will /always/ result in a valid app, either the old one
                -- will continue running or the new one will replace it.
                Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return (App -> Maybe App
forall a. a -> Maybe a
Just App
app)
            Right () -> Maybe App -> IO (Maybe App)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe App -> IO (Maybe App)) -> Maybe App -> IO (Maybe App)
forall a b. (a -> b) -> a -> b
$ App -> Maybe App
forall a. a -> Maybe a
Just App
app

    name :: Appname
name =
        case AppId
appid of
            AppId
AIBuiltin -> Appname
"<builtin>"
            AINamed Appname
x -> Appname
x

addApp :: AppManager -> FilePath -> IO ()
addApp :: AppManager -> FilePath -> IO ()
addApp AppManager
appMan FilePath
bundle = do
    (AppId
input, Action
action) <- FilePath -> IO (AppId, Action)
getInputForBundle FilePath
bundle
    AppManager -> AppId -> Action -> IO ()
perform AppManager
appMan AppId
input Action
action

getInputForBundle :: FilePath -> IO (AppId, Action)
getInputForBundle :: FilePath -> IO (AppId, Action)
getInputForBundle FilePath
bundle = do
    EpochTime
time <- FileStatus -> EpochTime
modificationTime (FileStatus -> EpochTime) -> IO FileStatus -> IO EpochTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
getFileStatus FilePath
bundle
    (AppId, Action) -> IO (AppId, Action)
forall (m :: * -> *) a. Monad m => a -> m a
return (Appname -> AppId
AINamed (Appname -> AppId) -> Appname -> AppId
forall a b. (a -> b) -> a -> b
$ FilePath -> Appname
getAppname FilePath
bundle, AppInput -> Action
Reload (AppInput -> Action) -> AppInput -> Action
forall a b. (a -> b) -> a -> b
$ FilePath -> EpochTime -> AppInput
AIBundle FilePath
bundle EpochTime
time)

terminateApp :: AppManager -> Appname -> IO ()
terminateApp :: AppManager -> Appname -> IO ()
terminateApp AppManager
appMan Appname
appname = AppManager -> AppId -> Action -> IO ()
perform AppManager
appMan (Appname -> AppId
AINamed Appname
appname) Action
Terminate