keter/Keter/AppManager.hs

{-# 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 qualified Filesystem.Path.CurrentOS as F
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
    { apps           :: !(TVar (Map AppId (TVar AppState)))
    , appStartConfig :: !AppStartConfig
    , mutex          :: !(MVar ())
    , 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 log' asc = AppManager
    <$> newTVarIO Map.empty
    <*> return asc
    <*> newMVar ()
    <*> return 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 am@AppManager {..} newApps = withMVar mutex $ const $ do
    actions <- atomically $ do
        m <- readTVar apps
        let currentApps = Set.fromList $ mapMaybe toAppName $ Map.keys m
            allApps = Set.toList $ Map.keysSet newApps `Set.union` currentApps
        fmap catMaybes $ mapM (getAction m) allApps
    sequence_ actions
  where
    toAppName AIBuiltin = Nothing
    toAppName (AINamed x) = Just x

    getAction currentApps appname = do
        case Map.lookup (AINamed appname) currentApps of
            Nothing -> return freshLaunch
            Just tstate -> do
                state <- readTVar tstate
                case state of
                    ASTerminated -> return freshLaunch
                    ASRunning app ->
                        case Map.lookup appname newApps of
                            Nothing -> return terminate
                            Just (fp, newTimestamp) -> do
                                moldTimestamp <- App.getTimestamp app
                                return $ if moldTimestamp == Just newTimestamp
                                    then Nothing
                                    else reload fp newTimestamp
                    ASStarting _ tmoldTimestamp tmaction ->
                        case Map.lookup appname newApps of
                            Nothing -> do
                                writeTVar tmaction $ Just Terminate
                                return Nothing
                            Just (fp, newTimestamp) -> do
                                moldTimestamp <- readTVar tmoldTimestamp
                                return $ if moldTimestamp == Just newTimestamp
                                    then Nothing
                                    else reload fp newTimestamp
      where
        freshLaunch =
            case Map.lookup appname newApps of
                Nothing -> E.assert False Nothing
                Just (fp, timestamp) -> reload fp timestamp
        terminate = Just $ performNoLock am (AINamed appname) Terminate
        reload fp timestamp = Just $ performNoLock am (AINamed appname) (Reload $ AIBundle fp 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 am appid action = withMVar (mutex am) $ const $ performNoLock am appid action

performNoLock :: AppManager -> AppId -> Action -> IO ()
performNoLock am@AppManager {..} aid action = E.mask_ $ do
    launchWorker' <- atomically $ do
        m <- readTVar apps
        case Map.lookup aid m of
            Just tstate -> do
                state <- readTVar tstate
                case state of
                    ASStarting _mcurrent _tmtimestamp tmnext -> do
                        writeTVar tmnext $ Just action
                        -- use the previous worker, so nothing to do
                        return noWorker
                    ASRunning runningApp -> do
                        tmnext <- newTVar Nothing
                        tmtimestamp <- newTVar $
                            case action of
                                Reload (AIBundle _fp timestamp) -> Just timestamp
                                Reload (AIData _) -> Nothing
                                Terminate -> Nothing
                        writeTVar tstate $ ASStarting (Just runningApp) tmtimestamp tmnext
                        return $ launchWorker am aid tstate tmnext (Just runningApp) action
                    ASTerminated -> onNotRunning
            Nothing -> onNotRunning
    launchWorker'
  where
    noWorker = return ()

    onNotRunning =
        case action of
            Reload input -> do
                tmnext <- newTVar Nothing
                tmtimestamp <- newTVar $
                    case input of
                        AIBundle _fp timestamp -> Just timestamp
                        AIData _ -> Nothing
                tstate <- newTVar $ ASStarting Nothing tmtimestamp tmnext
                modifyTVar apps $ Map.insert aid tstate
                return $ launchWorker am aid tstate tmnext Nothing action
            Terminate -> return noWorker

launchWorker :: AppManager
             -> AppId
             -> TVar AppState
             -> TVar (Maybe Action)
             -> Maybe App
             -> Action
             -> IO ()
launchWorker AppManager {..} appid tstate tmnext mcurrentApp0 action0 = void $ forkIO $ do
    loop mcurrentApp0 action0
  where
    loop mcurrentApp action = do
        mRunningApp <- processAction mcurrentApp action
        mnext <- atomically $ do
            mnext <- readTVar tmnext
            writeTVar tmnext Nothing
            case mnext of
                Nothing ->
                    case mRunningApp of
                        Nothing -> writeTVar tstate ASTerminated
                        Just runningApp -> writeTVar tstate $ ASRunning runningApp
                Just _next -> do
                    tmtimestamp <- newTVar $
                        case action of
                            Reload (AIBundle _fp timestamp) -> Just timestamp
                            Reload (AIData _) -> Nothing
                            Terminate -> Nothing
                    writeTVar tstate $ ASStarting mRunningApp tmtimestamp tmnext
            return mnext
        case mnext of
            Nothing -> return ()
            Just next -> loop mRunningApp next

    processAction Nothing Terminate = return Nothing
    processAction (Just app) Terminate = do
        App.terminate app
        return Nothing
    processAction Nothing (Reload input) = do
        eres <- E.try $ App.start appStartConfig appid input
        case eres of
            Left e -> do
                let name =
                        case appid of
                            AIBuiltin -> "<builtin>"
                            AINamed x -> x
                log $ ErrorStartingBundle name e
                return Nothing
            Right app -> return $ Just app
    processAction (Just app) (Reload input) = do
        App.reload app input
        -- reloading will /always/ result in a valid app, either the old one
        -- will continue running or the new one will replace it.
        return $ Just app

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

getInputForBundle :: FilePath -> IO (AppId, Action)
getInputForBundle bundle = do
    time <- modificationTime <$> getFileStatus (F.encodeString bundle)
    return (AINamed $ getAppname bundle, Reload $ AIBundle bundle time)

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